Getting servlet2 back to working shape. Changes include:

Wrapped the major servlet2 functions so they talk to a running server
  thread under an on-web context.

  Bumped timeout to +inf.

  When starting server, checks to see if the port is available.  If not,
  tries to choose 8001, 8002, ... up to 8032 before giving up.

svn: r10806

collects/htdp/servlet2.ss

@@ -1,14 +1,17 @@
-(module servlet2 mzscheme
+(module servlet2 scheme/base
   #| TODO -----------------------------------------------------------------------
         buttons: multiple points of returns: continuation functions 
   |#
-     (require web-server/servlet-env
+  (require (prefix-in servlet: web-server/servlet-env)
            htdp/error
-              mzlib/list
+           scheme/tcp
-              mzlib/etc)
+           scheme/bool
-     (provide (all-from web-server/servlet-env)
+           scheme/list
+           scheme/match)
   
-              single-query        ; FormElement -> Answer
+  (require (for-syntax scheme/base))
+  
+  (provide single-query ; FormElement -> Answer
            
            queries             ; (listof FormElement) -> (listof Answer)
            echo-answers        ; (listof Answers) -> true
@@ -24,15 +27,22 @@
            
            ; Structures  --------------------------------------------------------------
            make-password
-              (rename make-numeric make-number)
+           (rename-out (make-numeric make-number)
+                       (make-check make-boolean))
            make-yes-no
-              (rename make-check make-boolean)
            make-radio
            ;   make-button
            
            form? 
            form-element?
            
+           ;; Advanced API from servlet-env:
+           send/suspend
+           send/finish
+           (rename-out (servlet:extract-binding/single extract-binding/single)
+                       (servlet:extract-bindings extract-bindings))
+           
+           
            #| Data Definitions --------------------------------------------------------
            
            FormElement = (union String
@@ -76,10 +86,10 @@
        (let ([make-variable 
               ; String SyntaxObject -> SyntaxObject
               (lambda (x y)
-                   (datum->syntax-object
+                (datum->syntax
                  stx
                  (string->symbol 
-                     (format "~a-~a" x (syntax-object->datum y)))))])
+                  (format "~a-~a" x (syntax->datum y)))))])
          (with-syntax ([make-name   (make-variable "make" (syntax name))]
                        [(x ...) (generate-temporaries (syntax (pred? ...)))])
            (syntax
@@ -166,14 +176,14 @@
   
   ; FormElement -> Answer
   ; to pose one question, receive one answer 
-     (define (single-query fe)
+  (define (internal:single-query fe)
     (check-arg 'single-query (form-element? fe) "form element" "first" fe)
-       (car (queries (list fe))))
+    (car (internal:queries (list fe))))
   
   ; (listof FormElement) -> (listof Answer)
   ; to ask N questions and to get N answers
   ; assert: (lambda (result) (= (length fes) (length result)))
-     (define (queries fes)
+  (define (internal:queries fes)
     (check-arg 'queries (and (list? fes) (andmap form-element? fes))
                "list of form elements" "first" fes)
     (conduct-query "Web Query" (map list (make-keys fes) fes)))
@@ -181,7 +191,7 @@
   ; Form -> Bindings 
   ; to ask N questions with tags, receive N answers 
   ; assert: (lambda (result) (set-equal? (map car aloss) (map car result)))
-     (define (form-query f)
+  (define (internal:form-query f)
     (check-list-list 'form-query (form? f) "form" f)
     (map list (map first f)
          (conduct-query "Web Query" (map list (make-keys f) (map second f)))))
@@ -209,7 +219,7 @@
   
   ; Response -> true
   ; to display a response on a web page 
-     (define (echo-response form)
+  (define (internal:echo-response form)
     (make-echo-page
      (map (lambda (tag answer)
             `(tr (td ,(symbol->string tag))
@@ -219,7 +229,7 @@
   
   ; (listof Answer) -> true
   ; to display a list of answers on a web page
-     (define (echo-answers form)
+  (define (internal:echo-answers form)
     (make-echo-page 
      (map (lambda (answer) `(tr (td ,(answer->string answer)))) form)))
   
@@ -227,11 +237,11 @@
   
   ; String String *-> true
   ; to deliver an intermediate message and a link to continue
-     (define (inform title . paragraph)
+  (define (internal:inform title . paragraph)
     (check-arg 'inform (string? title) "string" "first" title)
     (check-arg 'inform (andmap string? paragraph) 
                "list of strings" "second, third, ..." paragraph)
-       (send/suspend 
+    (servlet:send/suspend
      (lambda (url)
        `(html 
          (title ,title)
@@ -243,9 +253,11 @@
                (a ([href ,url]) "Continue")))))
     #t)
   
+  
+  
   ; (listof Xexpr) -> true 
-     (define (inform/html stuff)
+  (define (internal:inform/html stuff)
-       (send/suspend 
+    (servlet:send/suspend
      (lambda (url)
        `(html 
          (title "Information")
@@ -258,11 +270,11 @@
   
   ; String String *-> true
   ; to deliver a final web page and terminate the web dialog
-     (define (final-page title . paragraph)
+  (define (internal:final-page title . paragraph)
     (check-arg 'final-page (string? title) "string" "first" title)
     (check-arg 'final-page (andmap string? paragraph) 
                "list of strings" "second, third, ..." paragraph)
-       (send/finish
+    (servlet:send/finish
      `(html 
        (title ,title)
        (body ([bgcolor "white"])
@@ -300,7 +312,7 @@
   ; effect:  raise 'yes-no if a yes-no button goes unchecked 
   (define (get-binding restart tag bindings fe cq)
     (let ([cq       (compose restart cq)]
-             [result   (extract-bindings tag bindings)]
+          [result (servlet:extract-bindings tag bindings)]
           [question "Please respond to the question:"])
       (cond
         [(check? fe) (if (null? result) #f #t)]
@@ -322,8 +334,8 @@
   ; String Form -> FormResults
   ; assert: (lambda (result) (set-equal? (domain aloss) (domain result)))
   (define (build-form title f)
-       (request-bindings
+    (servlet:request-bindings
-        (send/suspend
+     (servlet:send/suspend
       (lambda (url) 
         `(html 
           (title ,title)
@@ -407,7 +419,7 @@
   ; (listof Xexpr[tr]) -> true 
   ; echo stuff, wait for click on continue link
   (define (make-echo-page stuff)
-       (send/suspend
+    (servlet:send/suspend
      (lambda (url)
        `(html
          (title "Echoed Answers")
@@ -421,4 +433,139 @@
   
   ; constants -----------------------------------------------------------------
   (define SUBMIT-BUTTON '(input ([type "submit"][value "Submit"])))
-     )
+  
+  
+  
+  
+  ;                                            
+  ;                                            
+  ;                                            
+  ;    ;;;;                                    
+  ;   ;;   ;                                   
+  ;   ;       ;;;    ; ;;  ;   ;   ;;;    ; ;; 
+  ;   ;;     ;;  ;   ;;  ; ;   ;  ;;  ;   ;;  ;
+  ;    ;;;;  ;   ;   ;      ; ;   ;   ;   ;    
+  ;       ;; ;;;;;   ;      ; ;   ;;;;;   ;    
+  ;        ; ;       ;      ;;;   ;       ;    
+  ;   ;   ;; ;;  ;   ;       ;    ;;  ;   ;    
+  ;    ;;;;   ;;;    ;       ;     ;;;    ;    
+  ;                                            
+  ;                                            
+  ;                                     ;    ;;
+  
+  
+  ;; Returns the next port over 8000 that we can try
+  (define (get-next-port)
+    (define starting-at 8000)
+    (define max-attempts 32)
+    (let loop ([port-no starting-at]
+               [attempts 0])
+      (let ([port-available?
+             (with-handlers ([exn:fail:network?
+                              (lambda (exn) #f)])
+               (let ([listener (tcp-listen port-no 4 #t #f)])
+                 (tcp-close listener)
+                 #t))])
+        (cond
+          [port-available?
+           port-no]
+          [(< attempts max-attempts)
+           (loop (add1 port-no) (add1 attempts))]
+          [else
+           (error 'get-next-port
+                  "Couldn't find an available port between ~a and ~a~n"
+                  starting-at (+ starting-at max-attempts))]))))
+  
+  
+  
+  (define in-ch (make-parameter (make-channel)))
+  (define current-server (make-parameter #f))
+  
+  ;; A request is a (make-req thunk res-ch) where thunk is a (-> any) and res-ch is a
+  ;; channel.
+  (define-struct req ())
+  (define-struct (req:standard req) (thunk res-ch))
+  (define-struct (req:stop-server req) (thunk res-ch))
+  
+  ;; An error response holds the exception that happened.
+  (define-struct error-res (exn))
+  
+  ;; A server consists of the maintenance thread.
+  (define-struct server (t) #:mutable)
+  
+  ;; ensure-standalone-server-running!: -> void
+  ;; Makes sure that the standalone server is up and running.
+  (define (ensure-standalone-server-running!)
+    (unless (current-server)
+      (let ([a-server (make-server #f)])
+        (current-server a-server)
+        (thread (lambda ()
+                  (set-server-t! a-server (current-thread))
+                  (let ([port (get-next-port)])
+                    (servlet:on-web port (begin
+                                           (servlet:adjust-timeout! +inf.0)
+                                           (server-loop a-server)))))))))
+  
+  (define (server-loop a-server)
+    (let loop ()
+      (let ([msg (channel-get (in-ch))])
+        (match msg
+          
+          [(struct req:stop-server (thunk res-ch))
+           (channel-put res-ch (with-handlers ([void make-error-res])
+                                 (thunk)))
+           (current-server #f)]
+          
+          [(struct req:standard (thunk res-ch))
+           (channel-put res-ch (with-handlers ([void make-error-res])
+                                 (thunk)))
+           (loop)]))))
+  
+  
+  (define (make-wrapped-function internal:function make-request)
+    (lambda args
+      (ensure-standalone-server-running!)
+      (let ([res-ch (make-channel)])
+        (channel-put (in-ch) 
+                     (make-request (lambda () (apply internal:function args))
+                                   res-ch))
+        (let ([result 
+               (channel-get res-ch)])
+          (cond
+            [(error-res? result)
+             (raise (error-res-exn result))]
+            [else
+             result])))))
+  
+  ;; Provides wrappers around the internal functions to make the wrapped functions
+  ;; run in the context of a standalone server.
+  (define-syntax (define-wrapped-function stx)
+    (syntax-case stx ()
+      [(_ function internal:function #:final final)
+       (with-syntax ([make-request (if (syntax->datum #'final)
+                                       #'make-req:stop-server
+                                       #'make-req:standard)])
+         (syntax/loc stx 
+           (define function (make-wrapped-function internal:function make-request))))]
+      
+      [(_ function internal:function)
+       (syntax/loc stx
+         (define-wrapped-function function internal:function #:final #f))]))
+  
+  
+  (define-wrapped-function single-query internal:single-query)
+  (define-wrapped-function queries internal:queries)
+  (define-wrapped-function echo-answers internal:echo-answers)
+  
+  (define-wrapped-function form-query internal:form-query)
+  (define-wrapped-function echo-response internal:echo-response)
+  
+  (define-wrapped-function inform/html internal:inform/html)
+  (define-wrapped-function inform internal:inform)
+  
+  
+  ;; fixme: on final-page, send/finish seems to stop the thread.
+  (define-wrapped-function final-page internal:final-page #:final #t)
+  
+  (define-wrapped-function send/suspend servlet:send/suspend)
+  (define-wrapped-function send/finish servlet:send/finish))