PR1411 Jays observations re thread-server

pkgs/net-test/tests/net/http-proxy/echo-server.rkt

@@ -1,22 +1,28 @@
 #lang racket/base
-; An echo server -- ripped off the racket homepage
-(provide server current-listen-port)
+(provide server current-listen-port current-conn-timeout)
 
 (require racket/port "generic-server.rkt")
 
 (define (server)
+  ;; Although this is ≡ (serve copy-port), I’m explicit about i and o
+  ;; to illustrate the calling convention for serve
   (serve (lambda (i o) (copy-port i o))))
 
 (module+
   main
   (define-values (server-thread shutdown-server) (server))
-  (thread-wait server-thread))
+  (dynamic-wind
+   void
+   (λ () (thread-wait server-thread))
+   shutdown-server))
 
 (module+
     test
   (require rackunit racket/tcp)
   (define-values (server-thread shutdown-server) (server))  
-
+  (dynamic-wind
+   void
+   (λ ()
      (define-values (cl:from cl:to)
        (tcp-connect "localhost" (current-listen-port)))
      (file-stream-buffer-mode cl:to 'none)
@@ -25,6 +31,5 @@
      (flush-output cl:to)
      (close-output-port cl:to)
      (check-equal? (read-string 1024 cl:from) "Monkeys!")
- (tcp-abandon-port cl:from)
- (sleep 5)
- (shutdown-server))
+     (tcp-abandon-port cl:from))
+   shutdown-server))

pkgs/net-test/tests/net/http-proxy/generic-server.rkt

@@ -1,38 +1,35 @@
 #lang racket/base
-;; with thanks to "More: Systems Programming with Racket"
-(provide serve current-listen-port)
+(provide serve
+         current-listen-port
+         current-conn-timeout)
 
-(require racket/tcp)
+(require mzlib/thread
+         racket/tcp)
 
 (define current-listen-port (make-parameter 12345))
 
-(define (accept-and-handle listener handler)
-  (define cust (make-custodian))
-  (define handler-thread
-    (parameterize ([current-custodian cust])
-      (define-values (in out) (tcp-accept listener))
-      (file-stream-buffer-mode in 'none)
-      (file-stream-buffer-mode out 'none)
-      (thread (lambda ()
-                (handler in out)
-                (close-output-port out)
-                (close-input-port in)))))
-  (thread (lambda ()
-            (thread-wait handler-thread)
-            (custodian-shutdown-all cust))))
+(define current-conn-timeout (make-parameter #f))
 
-(define (serve handler)
-  (define serving-sem (make-semaphore))
-  (define main-cust (make-custodian))
-  (define server-thread
-    (parameterize ([current-custodian main-cust])
-      (define listener (tcp-listen (current-listen-port) 5 #t))
-      (semaphore-post serving-sem) ; listening... so caller is ready to continue
-      (define (loop)
-        (accept-and-handle listener handler)
-        (loop))
-      (thread loop)))
-  (values server-thread (lambda () (custodian-shutdown-all main-cust))))
+(define (serve conn-proc)
+  ;; use of semaphore `s` allows us to wait until the server is listening before continuing
+  ;; -- needed for test suites that “just want to get on with it”
+  (define s (make-semaphore 0))
+  (define t (thread
+             (λ ()
+               (run-server (current-listen-port)
+                           conn-proc
+                           (current-conn-timeout)
+                           void ; handler
+                           (λ (port-no
+                               (max-allow-wait 4)
+                               (reuse? #f)
+                               (hostname #f))
+                             (dynamic-wind
+                              void
+                              (λ () (tcp-listen port-no max-allow-wait reuse? hostname))
+                              (λ () (semaphore-post s))))))))
+  (semaphore-wait s)
+  (values t (λ () (kill-thread t))))
 
 ;; tested via the echo-server (in this directory)
 ;; (module+ test)

pkgs/net-test/tests/net/http-proxy/https-non-server.rkt

@@ -1,16 +1,15 @@
 #lang racket/base
 ; It may look like an HTTPS server, but it very isn’t
-(provide server current-listen-port)
+(provide server
+         current-listen-port
+         current-conn-timeout)
 
 (require racket/match
-         racket/port
          openssl
          syntax/modresolve
          "generic-server.rkt")
 
-(define (server)
-  (serve
-    (lambda (i o)
+(define (conn-proc i o)  
   (define ssl-srvr-ctx (ssl-make-server-context 'secure))
   (define test.pem-path (build-path
                          (let-values (([base name mbd?]
@@ -23,8 +22,7 @@
                       #:mode 'accept
                       #:context ssl-srvr-ctx
                       #:close-original? #t
-                          #:shutdown-on-close? #t
-                          ))
+                      #:shutdown-on-close? #t))
   (define request-lines
     (for/list ((l (in-lines s:i 'return-linefeed)) #:break (string=? l "")) l))
   (define-syntax-rule (out/flush fmt args ...)
@@ -39,11 +37,13 @@
     [(cons (regexp #px"^(\\S+)\\s+(\\S+)(\\s+HTTP/\\S+)?$"
                    (list request method request-uri http-version)) _)
      (out/flush "HTTP/1.1 405 Method Not Allowed\r\n\r\n")]
-             [_ (out/flush "HTTP/1.1 400 Bad Request\r\n\r\n")]))))
+    [_ (out/flush "HTTP/1.1 400 Bad Request\r\n\r\n")]))
+
+(define (server) (serve conn-proc))
 
 (module+
   main
   (define-values (server-thread shutdown-server) (server))
-  (thread-wait server-thread))
+  (dynamic-wind void (λ () (thread-wait server-thread)) shutdown-server))
 
 (module+ test)

pkgs/net-test/tests/net/http-proxy/proxy-server.rkt

@@ -3,9 +3,9 @@
 ;; oozes security leaks and I wouldn’t be surprised if it leaked fids too.
 (require racket/port racket/match racket/tcp "generic-server.rkt")
 
-(provide server current-listen-port)
-
-(define serving-sem (make-semaphore))
+(provide server
+         current-listen-port
+         current-conn-timeout)
 
 (define (http-tunnel-serve in out)
   (let/ec