From a817635bb616acc6dd64072b369de157a761b4e2 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Wed, 24 Aug 2005 16:02:16 +0000 Subject: [PATCH] Creating standalone servlet module svn: r646 --- collects/web-server/info.ss | 4 +- collects/web-server/servlet-env.ss | 75 +++++++++++ collects/web-server/servlet-primitives.ss | 156 ---------------------- 3 files changed, 76 insertions(+), 159 deletions(-) create mode 100644 collects/web-server/servlet-env.ss delete mode 100644 collects/web-server/servlet-primitives.ss diff --git a/collects/web-server/info.ss b/collects/web-server/info.ss index 705da9b830..58531b142a 100644 --- a/collects/web-server/info.ss +++ b/collects/web-server/info.ss @@ -4,6 +4,4 @@ (define mzscheme-launcher-names (list "web-server-text" "web-server-monitor")) (define mred-launcher-libraries (list "gui-launch.ss")) - (define mred-launcher-names (list "web-server")) - - (define compile-omit-files (list "servlet-primitives.ss"))) + (define mred-launcher-names (list "web-server"))) diff --git a/collects/web-server/servlet-env.ss b/collects/web-server/servlet-env.ss new file mode 100644 index 0000000000..76e71ab33a --- /dev/null +++ b/collects/web-server/servlet-env.ss @@ -0,0 +1,75 @@ +(module servlet-env mzscheme + (require "configuration.ss" + "web-server.ss" + "sig.ss" + "servlet.ss" + "connection-manager.ss" + "servlet-tables.ss" + "util.ss" + "response.ss") + (require (lib "url.ss" "net") + (lib "external.ss" "browser") + (lib "unitsig.ss") + (lib "tcp-sig.ss" "net")) + (provide (rename on-web:syntax on-web) + (all-from "servlet.ss")) + + (define-syntax (on-web:syntax stx) + (syntax-case stx () + [(on-web:syntax servlet-expr) + (with-syntax ([initial-request (datum->syntax-object (syntax servlet-expr) 'initial-request)]) + (syntax + (on-web (lambda (initial-request) servlet-expr) + 8000 + "servlets/standalone.ss")))])) + + (define (on-web servlet-expr the-port the-path) + (let* ([standalone-url + (format "http://localhost:~a/~a" the-port the-path)] + [final-value + (void)] + [final-conn + (void)] + [sema + (make-semaphore 0)] + [new-servlet + (unit/sig () (import servlet^) + (let ([v (servlet-expr initial-request)]) + (set! final-value v) + ;(set! final-conn (execution-context-connection (servlet-instance-context (current-servlet-instance)))) + (semaphore-post sema) + (if (response? v) + v + `(html (head (title "Servlet has ended.")) + (body (p "This servlet has ended, please return to the interaction window."))))))] + [shutdown-server + (run-the-server (build-standalone-servlet-configuration the-port the-path new-servlet))]) + (send-url standalone-url #t) + ; Wait for final call + (semaphore-wait sema) + ; XXX: Find a way to wait for final HTML to be sent + ; Shutdown the server + (shutdown-server) + final-value)) + + (define (build-standalone-servlet-configuration the-port the-path the-servlet) + (let ([basic-configuration@ (load-developer-configuration default-configuration-table-path)] + [the-scripts (make-hash-table 'equal)]) + (define-values/invoke-unit/sig web-config^ basic-configuration@ i) + (hash-table-put! the-scripts + (build-path (directory-part default-configuration-table-path) + "default-web-root" "." + the-path) + the-servlet) + (unit/sig web-config^ + (import) + (define port the-port) + (define max-waiting i:max-waiting) + (define listen-ip i:listen-ip) + (define initial-connection-timeout i:initial-connection-timeout) + (define virtual-hosts i:virtual-hosts) + (define access i:access) + (define instances i:instances) + (define scripts (box the-scripts)) + (define scripts-lock i:scripts-lock) + (define make-servlet-namespace i:scripts-lock))))) \ No newline at end of file diff --git a/collects/web-server/servlet-primitives.ss b/collects/web-server/servlet-primitives.ss deleted file mode 100644 index 4387af90b9..0000000000 --- a/collects/web-server/servlet-primitives.ss +++ /dev/null @@ -1,156 +0,0 @@ -;; NOTES: -;; 1. This is where the send/blah primtives are defined that get used by the -;; servlet and servlet2 teachpacks. -;; 2. There's no chance that this code works anymore, and so I've excluded it -;; from compilation in the info.ss until I have a chance to get the -;; teachpacks going again. -;; 3. In the original server, send/blah were implemented twice, once for the -;; normal server and then again in here for the teachpacks. Now that I've -;; got the new continuation model in place, I will see if I can eliminate -;; this redundancy. - -(module servlet-primitives mzscheme - (require "channel.ss" - "configuration.ss" - ;"configuration-structures.ss" - "web-server-unit.ss" - "min-servlet.ss" - ;"servlet.ss" - "servlet-tables.ss" - "internal-structs.ss" - ;(lib "xml.ss" "xml") - (lib "url.ss" "net") - (lib "external.ss" "browser") - ; more here - use contracts when they support suitable error messages - ;(lib "contracts.ss" "framework") - (lib "unitsig.ss") - (lib "tcp-sig.ss" "net") - ) - (provide servlet@) - - ; the unit doesn't contain much since it's better to start as few servers as possible - ; this is unitized so the servlet2.ss teachpack can work with either - ; the development environment or with the actual server. - ; more here - maybe this is not needed anymore with the parameter that - ; affects send/suspend. - (define servlet@ - (unit/sig servlet^ - (import) - - (define send/suspend the-send/suspend) - (define send/finish the-send/finish) - (define send/back the-send/back) - (define send/forward the-send/forward) - (define initial-request the-initial-request) - (define adjust-timeout! the-adjust-timeout!))) - - ; : num -> void - (define (the-adjust-timeout! n) (void)) - - ; send/finish : response -> doesn't - (define (the-send/finish page) - (unless (response? page) - (error 'send/finish "expected as 1st argument, given: ~e" - page)) - (output-page page) - (kill-thread (current-thread)) - (set! *page-channel* #f)) - - ; *page-channel* : #f | channel - (define *page-channel* #f) - - ; update-channel! : channel -> void - (define (update-channel! x) - (set! *page-channel* x)) - - (define *last-page-sent* #f) - ;(define *open-new-window* #t) - ; always re-use an exisiting window. - (define *open-new-window* #f) - - ; output-page : page -> void - (define (output-page page) - (set! *last-page-sent* page) - ;(unless *page-channel* - ; (init-channel)) - (init-channel) - (async-channel-put *page-channel* page)) - - ; : instance -> doesn't - (define resume-next-request - (gen-resume-next-request void update-channel!)) - - ; init-channel : -> void - (define (init-channel) - ((gen-send/suspend uri invoke-id instances void resume-next-request) - (lambda (url) - (send-url url *open-new-window*) - (set! *open-new-window* #f)))) - - (define-values (listener port) - (let loop ([port 8000]) - (with-handlers ([void (lambda (exn) (loop (add1 port)))]) - (values (tcp-listen port 10 #f "127.0.0.1") - port)))) - - (define instances (make-hash-table)) - (define uri (string->url (format "http://127.0.0.1:~a/servlets/" port))) - (define invoke-id (string->symbol (symbol->string (gensym "id")))) - - ; : (str -> response) -> request - (define the-send/suspend - (lambda (k->page) - (let ((s/s (gen-send/suspend uri invoke-id instances output-page resume-next-request))) - (s/s (lambda (k-url) - (let ([page (k->page k-url)]) - (unless (response? page) - (error 'send/suspend "expected <~a> as 1st argument, given a function that produced: ~e" - "a function that produces a response" - page)) - page)))))) - - ; : (response -> doesn't) - (define (the-send/back page) - (the-send/suspend (lambda (not-used-k-url) page))) - - ; : (str -> response) -> request - (define (the-send/forward page-maker) - ;(set-servlet-instance-cont-table! - ; (hash-table-get invoke-id instances) - ; (make-hash-table)) - ; FIX - this is wrong. The hash table must be cleared or the reference in the server must be reset, not our reference. - ; try (set-config-instances! the-config (make-hash-table)) -; (set! instances (make-hash-table)) -; (add-new-instance invoke-id instances) -; (the-send/suspend page-maker)) - (purge-table 'post uri instances invoke-id - (lambda (inst) (set-servlet-instance-cont-table! inst (make-hash-table)))) - (the-send/suspend page-maker)) - - - (define the-initial-request - (make-request 'post uri null null "127.0.0.1" "127.0.0.1")) - - (add-new-instance invoke-id instances) - - ; override some configuration options - (define the-configuration@ - (load-developer-configuration default-configuration-table-path)) - - (thread (lambda () - (invoke-unit/sig - (compound-unit/sig - (import (T : net:tcp^)) - (link - [c : web-config^ ((update-configuration the-configuration@ `((instances . ,instances))))] - [s : web-server^ (web-server@ T C)] - [m : () ((unit/sig () - (import web-server^) - (server-loop (current-custodian) - (lambda () (tcp-accept listener)) - (lambda () - (init-channel) - (async-channel-put *page-channel* *last-page-sent*)))) - s)]) - (export)) - net:tcp^))))