did comet-style server push

assemble.rkt

@@ -11,12 +11,22 @@
 (: assemble/write-invoke ((Listof Statement) Output-Port -> Void))
 (define (assemble/write-invoke stmts op)
   (let ([basic-blocks (fracture stmts)])
-    (fprintf op "function(k) {\n")
+    (fprintf op "function(success, fail, params) {\n")
+    (fprintf op "var param;\n")
     (for-each (lambda: ([basic-block : BasicBlock])
                 (displayln (assemble-basic-block basic-block) op)
                 (newline op))
               basic-blocks)
-    (fprintf op "MACHINE.cont = k;\n")
+    (fprintf op "MACHINE.cont = success;\n")
+    (fprintf op "MACHINE.params.currentErrorHandler = function(e) { fail(e); };\n")
+    (fprintf op #<<EOF
+for (param in params) {
+    if (params.hasOwnProperty(param)) {
+        MACHINE.params[param] = params[param];
+    }
+}
+EOF
+             )
     (fprintf op "trampoline(~a, function() {}, function(e) { MACHINE.params.currentErrorHandler(e)}); }"
              (BasicBlock-name (first basic-blocks)))))
 

browser-evaluate.rkt

@@ -1,15 +1,16 @@
 #lang racket/base
 
-(require net/sendurl
+(require racket/list
-         racket/list
          web-server/servlet
          web-server/servlet-env
          "package.rkt")
 
 ;; A hacky way to test the evaluation.
 ;;
-;; TODO: figure out how to do this without so many urls.  Push-style from the server
+;; Sets up a web server and opens a browser window.
-;; should be able to work.
+;; The page on screen periodically polls the server to see if a program has
+;; come in to be evaluated.  Whenever code does come in, evaluates and returns the
+;; value to the user, along with the time it took to evaluate.
 
 
 (provide evaluate)
@@ -17,7 +18,7 @@
 (define port (+ 8000 (random 8000)))
 
 
-;; Channel's meant to serialize use of the web server.
+;; This channel's meant to serialize use of the web server.
 (define ch (make-channel))
 
 
@@ -29,21 +30,66 @@
  (thread (lambda ()
           (define (start req)
             (cond
-              [(exists-binding? 'p (request-bindings req))
+              ;; Server-side sync for a program
-               ;; Create a web page whose content contains
+              [(exists-binding? 'poke (request-bindings req))
-               ;; the script.
+               (handle-poke req)]
-               (let ([program (channel-get ch)]
+              
-                     [op (open-output-bytes)])
+              ;; Normal result came back
-                 (fprintf op #<<EOF
+              [(exists-binding? 'r (request-bindings req))
+               (handle-normal-response req)]
+
+              ;; Error occurred
+              [(exists-binding? 'e (request-bindings req))
+               (handle-error-response req)]
+              
+              [else
+               (make-on-first-load-response)]))
+
+          
+          (serve/servlet start 
+                         #:banner? #f
+                         #:launch-browser? #t
+                         #:quit? #f
+                         #:port port
+                         #:servlet-path "/eval"))))
+
+
+(define (handle-poke req)
+  ;; Fixme: add timeout protocol.
+  (let ([program (sync ch)])
+    (let ([op (open-output-bytes)])
+      (package-anonymous program op)
+      (response/full 200 #"Okay" 
+                     (current-seconds) 
+                     #"text/plain; charset=utf-8"
+                     empty 
+                     (list #"" (get-output-bytes op))))))
+
+
+
+
+(define (handle-normal-response req)
+  (channel-put ch (list (extract-binding/single 'r (request-bindings req))
+                        (string->number
+                         (extract-binding/single 't (request-bindings req)))))
+  `(html (body (p "ok"))))
+
+
+(define (handle-error-response req)
+  (channel-put ch (make-error-happened 
+                   (extract-binding/single 'e (request-bindings req))
+                   (string->number
+                    (extract-binding/single 't (request-bindings req)))))
+  `(html (body (p "ok"))))
+
+
+
+(define (make-on-first-load-response)
+  (let ([op (open-output-bytes)])
+    (fprintf op #<<EOF
 <html>
 <head>
 <script>
-EOF
-                          )
-                 (package program op)
-                 (fprintf op #<<EOF
-</script>
-<script>
 // http://www.quirksmode.org/js/xmlhttp.html
 //
 function sendRequest(url,callback,postData) {
@@ -86,69 +132,50 @@ function createXMLHTTPObject() {
 	return xmlhttp;
 }
 
+var poke = function() {
+    sendRequest("/eval", 
+                function(req) {
+                    var invoke = eval(req.responseText)();
+                    var output = [];
+                    var startTime, endTime;
+                    var params = { currentDisplayer: function(v) { output.push(String(v)); } };
+
+                    var onSuccess = function() {
+                        endTime = new Date();
+                        sendRequest("/eval", function(req) { setTimeout(poke, 0); },
+                            "r=" + encodeURIComponent(output.join('')) +
+                            "&t=" + encodeURIComponent(String(endTime - startTime)));
+                    };
+
+                    var onFail = function(e) {
+                        endTime = new Date();
+                        sendRequest("/eval", function(req) { setTimeout(poke, 0); },
+                            "e=" + encodeURIComponent(String(e)) +
+                            "&t=" + encodeURIComponent(String(endTime - startTime)));
+                    };
+                    startTime = new Date();
+                    invoke(onSuccess, onFail, params);
+                },
+                "poke=t");
+};
 
 var whenLoaded = function() {
-    var output = [], startTime, endTime;
+    setTimeout(poke, 0);
-    MACHINE.params.currentDisplayer = function(v) {
-        output.push(String(v));
-    };
-    MACHINE.params.currentErrorHandler = function(e) {
-        endTime = new Date();
-        document.body.appendChild(document.createTextNode(
-           "Program evaluated; sending back to DrRacket."));
-        sendRequest("/eval", function(req) {},
-                    "e=" + encodeURIComponent(String(e)) +
-                    "&t=" + encodeURIComponent(String(endTime - startTime)));
-    };
-    startTime = new Date();
-    invoke(
-        function() {
-            endTime = new Date();
-            document.body.appendChild(document.createTextNode(
-               "Program evaluated; sending back to DrRacket."));
-            sendRequest("/eval", function(req) {},
-                        "r=" + encodeURIComponent(output.join('')) +
-                        "&t=" + encodeURIComponent(String(endTime - startTime)));
-        });
 };
+
 </script>
 </head>
 <body onload="whenLoaded()">
-<p>Running program.</p>
+<p>Harness loaded.  Do not close this window.</p>
 </body>
 </html>
 EOF
-                          )
+             )
-                 (response/full 200 #"Okay" 
+    (response/full 200 #"Okay" 
-                                (current-seconds) 
+                   (current-seconds) 
-                                TEXT/HTML-MIME-TYPE
+                   TEXT/HTML-MIME-TYPE
-                                empty 
+                   empty 
-                                (list #"" (get-output-bytes op))))]
+                   (list #"" (get-output-bytes op)))))
-
-              ;; Normal result came back
-              [(exists-binding? 'r (request-bindings req))
-               (channel-put ch (list (extract-binding/single 'r (request-bindings req))
-                                     (string->number
-                                      (extract-binding/single 't (request-bindings req)))))
-               `(html (body (p "ok")))]
-
-              ;; Error occurred
-              [(exists-binding? 'e (request-bindings req))
-               (channel-put ch (make-error-happened 
-                                (extract-binding/single 'e (request-bindings req))
-                                (string->number
-                                 (extract-binding/single 't (request-bindings req)))))
-               `(html (body (p "ok")))]
-              
-              [else
-               `(html (body (p "Loaded")))]))
-          
-          (serve/servlet start 
-                         #:banner? #f
-                         #:launch-browser? #f
-                         #:quit? #f
-                         #:port port
-                         #:servlet-path "/eval"))))
 
 
 (define-struct error-happened (str t) #:transparent)
@@ -159,7 +186,6 @@ EOF
 ;; Returns the captured result of stdout, plus # of milliseconds it took to execute.
 (define (evaluate e)
   ;; Send the program to the web browser, and wait for the thread to send back
-  (send-url (format "http://localhost:~a/eval?p=t" port) #f)
   (channel-put ch e)
   (let ([output+time (channel-get ch)])
     (cond [(error-happened? output+time)

package.rkt

@@ -7,7 +7,8 @@
          racket/runtime-path
          racket/port)
 
-(provide package)
+(provide package
+         package-anonymous)
 
 ;; Packager: produce single .js files to be included.
 
@@ -27,3 +28,7 @@
   (fprintf op ";\n"))
 
 
+(define (package-anonymous source-code op)
+  (fprintf op "(function() {\n")
+  (package source-code op)
+  (fprintf op " return invoke; })\n"))