server: add support for graceful shutdown

.github/workflows/ci.yml

@@ -5,12 +5,16 @@ jobs:
     name: "Build on Racket '${{ matrix.racket-version }}' (${{ matrix.racket-variant }})"
     runs-on: ubuntu-latest
     strategy:
+      fail-fast: false
       matrix:
-        racket-version: ["8.0", "8.1", "current"]
+        racket-version: ["8.0", "8.1", "8.16", "8.17", "current"]
         racket-variant: ["BC", "CS"]
+        exclude:
+          - racket-variant: BC
+            racket-version: current
     steps:
       - uses: actions/checkout@master
-      - uses: Bogdanp/setup-racket@v1.11
+      - uses: Bogdanp/setup-racket@v1.14
         with:
           architecture: x64
           distribution: full

web-server-doc/web-server/scribblings/safety-limits.scrbl

@@ -45,7 +45,8 @@
              [#:max-form-data-field-length max-form-data-field-length nonnegative-length/c
               (code:line (* 8 1024) (code:comment #,(elem "8 KiB")))]
              [#:response-timeout response-timeout timeout/c 60]
-             [#:response-send-timeout response-send-timeout timeout/c 60])
+             [#:response-send-timeout response-send-timeout timeout/c 60]
+             [#:shutdown-grace-period shutdown-grace-period (or/c #f timeout/c) #f])
             safety-limits?]
    @defthing[nonnegative-length/c flat-contract?
              #:value (or/c exact-nonnegative-integer? +inf.0)]
@@ -144,7 +145,14 @@
    If your application uses streaming responses or long polling,
    either adjust this value or make sure that your request handler sends
    data periodically, such as a no-op, to avoid hitting this limit.
-   }]
+   }
+ @item{The @racket[shutdown-grace-period] argument controls how long,
+   during shutdown, the server will wait for in-flight requests to
+   finish before stopping. If @racket[#f], in-flight requests are killed
+   immediately. Otherwise, the server stops accepting new connections
+   and waits until either all in-flight requests complete, or the grace
+   period passes, at which point it shuts down its custodian.}
+ ]
 
 
  @elemtag["safety-limits-porting"]{@bold{Compatibility note:}}
@@ -202,7 +210,8 @@
           [#:max-form-data-fields max-form-data-fields nonnegative-length/c +inf.0]
           [#:max-form-data-field-length max-form-data-field-length nonnegative-length/c +inf.0]
           [#:response-timeout response-timeout timeout/c +inf.0]
-          [#:response-send-timeout response-send-timeout timeout/c +inf.0])
+          [#:response-send-timeout response-send-timeout timeout/c +inf.0]
+          [#:shutdown-grace-period shutdown-grace-period (or/c #f timeout/c) #f])
          safety-limits?]{
  Like @racket[make-safety-limits], but with default values that avoid
  imposing any limits that aren't explicitly specified,
@@ -217,4 +226,5 @@
 
  @history[#:added "1.6"]
  @history[#:changed "1.11" @elem{added the @racket[max-concurrent] limit}]
+ @history[#:changed "1.13" @elem{added the @racket[shutdown-grace-period] limit}]
 }

web-server-lib/info.rkt

@@ -14,7 +14,7 @@
 
 (define pkg-authors '(jay))
 
-(define version "1.12")
+(define version "1.13")
 
 (define license
   '(Apache-2.0 OR MIT))

web-server-lib/web-server/private/dispatch-server-with-connect-unit.rkt

@@ -37,14 +37,14 @@
       (thread
        (lambda ()
          (define listener
-           (with-handlers ([exn? (λ (e)
-                                   (async-channel-put* confirmation-channel e)
-                                   (raise e))])
+           (with-handlers ([exn?
+                            (lambda (e)
+                              (async-channel-put* confirmation-channel e)
+                              (raise e))])
              (tcp-listen config:port config:max-waiting #t config:listen-ip)))
          (define-values (_local-addr local-port _remote-addr _remote-port)
            (tcp-addresses listener #t))
          (async-channel-put* confirmation-channel local-port)
-
          (dynamic-wind
            void
            (lambda ()
@@ -60,48 +60,70 @@
              ;; not synchronizable.
              (define listener-evt (if (evt? listener) listener (handle-evt always-evt (λ (_) listener))))
              (define max-concurrent (safety-limits-max-concurrent config:safety-limits))
-             (let loop ([in-progress 0])
-               (loop
-                (with-handlers ([exn:fail:network? (λ (e)
-                                                     ((error-display-handler)
-                                                      (format "Connection error: ~a" (exn-message e))
-                                                      e)
-                                                     in-progress)])
-                  (do-sync
-                   (handle-evt
-                    (thread-receive-evt)
-                    (lambda (_)
-                      (let drain-loop ([in-progress in-progress])
-                        (if (thread-try-receive)
-                            (drain-loop (sub1 in-progress))
-                            in-progress))))
-                   (handle-evt
-                    (if (< in-progress max-concurrent) listener-evt never-evt)
-                    (lambda (l)
-                      (define custodian (make-custodian))
-                      (parameterize ([current-custodian custodian])
-                        (parameterize-break #f
-                          (define-values (in out)
-                            (do-accept l))
-                          (define handler-thd
-                            (thread
-                             (lambda ()
-                               (call-with-parameterization
-                                paramz
-                                (lambda ()
-                                  (when can-break? (break-enabled #t))
-                                  (parameterize ([current-custodian (make-custodian custodian)])
-                                    (handler in out)))))))
-                          (thread
-                           (lambda ()
-                             (thread-wait handler-thd)
-                             (thread-send listener-thd 'done)
-                             (custodian-shutdown-all custodian)))
-                          (add1 in-progress))))))))))
+             (let loop ([in-progress 0]
+                        [stopped? #f])
+               (define accepting?
+                 (and (not stopped?)
+                      (in-progress . < . max-concurrent)))
+               (define-values (in-progress* stopped?*)
+                 (with-handlers ([exn:fail:network?
+                                  (lambda (e)
+                                    ((error-display-handler)
+                                     (format "Connection error: ~a" (exn-message e))
+                                     e)
+                                    (values in-progress stopped?))])
+                   (do-sync
+                    (handle-evt
+                     (thread-receive-evt)
+                     (lambda (_)
+                       (match (thread-receive)
+                         ['done (values (sub1 in-progress) stopped?)]
+                         ['stop (values in-progress #t)])))
+                    (handle-evt
+                     (if accepting? listener-evt never-evt)
+                     (lambda (l)
+                       (define custodian (make-custodian))
+                       (parameterize ([current-custodian custodian])
+                         (parameterize-break #f
+                           (define-values (in out)
+                             (do-accept l))
+                           (define handler-thd
+                             (thread
+                              (lambda ()
+                                (call-with-parameterization
+                                  paramz
+                                  (lambda ()
+                                    (when can-break? (break-enabled #t))
+                                    (parameterize ([current-custodian (make-custodian custodian)])
+                                      (handler in out)))))))
+                           (thread
+                            (lambda ()
+                              (thread-wait handler-thd)
+                              (thread-send listener-thd 'done)
+                              (custodian-shutdown-all custodian)))
+                           (values (add1 in-progress) stopped?))))))))
+               (unless (and stopped?* (zero? in-progress*))
+                 (loop in-progress* stopped?*))))
            (lambda ()
              (tcp-close listener))))))
-    (lambda ()
-      (custodian-shutdown-all the-server-custodian))))
+    ;; When there is a grace period, calling stop the first time causes the server to stop accepting
+    ;; new connections and waits for in-progress connections to finish. Calling it a second time
+    ;; immediately kills the server. This can come in handy when implementing dev tooling where stop
+    ;; can be called after a break to begin shutdown, and it can be called again after another break
+    ;; to kill the server (eg. if the developer doesn't want to wait for requests in flight at that
+    ;; particular moment).
+    (let ([stopping? #f])
+      (lambda ()
+        (cond
+          [(and (not stopping?)
+                (safety-limits-shutdown-grace-period config:safety-limits))
+           => (lambda (timeout)
+                (set! stopping? #t)
+                (thread-send listener-thd 'stop)
+                (sync/timeout timeout listener-thd)
+                (custodian-shutdown-all the-server-custodian))]
+          [else
+           (custodian-shutdown-all the-server-custodian)])))))
 
 ;; serve-ports : input-port output-port -> void
 ;; returns immediately, spawning a thread to handle

web-server-lib/web-server/safety-limits.rkt

@@ -1,10 +1,10 @@
 #lang racket/base
 
-(require racket/contract
+(require (for-syntax racket/base
+                     racket/syntax)
+         racket/contract
          racket/match
-         syntax/parse/define
-         (for-syntax racket/base
-                     racket/syntax))
+         syntax/parse/define)
 
 ;; Also, define-safety-limits/private-submodule generates
 ;; a private submodule providing accessor functions and a match expander.
@@ -83,4 +83,5 @@
   max-form-data-parts nonnegative-length/c (+ max-form-data-fields max-form-data-files)
   max-form-data-header-length nonnegative-length/c (* 8 1024)
   response-timeout timeout/c 60
-  response-send-timeout timeout/c 60)
+  response-send-timeout timeout/c 60
+  shutdown-grace-period (or/c #f timeout/c) #f)

web-server-test/tests/web-server/all-web-server-tests.rkt

@@ -14,7 +14,8 @@
          "formlets-test.rkt"
          "dispatch-test.rkt"
          "servlet-env-test.rkt"
-         "test-tests.rkt")
+         "test-tests.rkt"
+         "serve-tests.rkt")
 (provide all-web-server-tests)
 
 (define all-web-server-tests
@@ -34,4 +35,5 @@
    all-servlet-tests
    servlet-env-tests
    test-tests
-   all-e2e-tests))
+   all-e2e-tests
+   serve-tests))

web-server-test/tests/web-server/e2e/README.md

@@ -4,9 +4,10 @@ These tests spin up real web servers in order to ensure that the
 system works end-to-end.  Each subfolder is expected to contain two
 files: `server.rkt` and `tests.rkt`.
 
-Each `server.rkt` module must provide a function called `start` that
-takes a port, starts a web server on that port and returns a function
-that can be used to stop the server.
+Each `server.rkt` module must provide a function called `start` starts a
+web server on an open port and returns a procedure that can be used to
+stop the server and the port the server is listening on.
 
 Each `tests.rkt` module must provide a function called `make-tests`
-that takes a port and returns a rackunit `test-suite`.
+that takes a port and a procedure that stops the server when called and
+returns a rackunit `test-suite`.

web-server-test/tests/web-server/e2e/all-e2e-tests.rkt

@@ -1,54 +1,39 @@
 #lang racket/base
 
 (require racket/path
-         racket/tcp
          rackunit)
 
 (provide all-e2e-tests)
 
-(define here
-  (simplify-path
-   (build-path (syntax-source #'here) 'up)))
-
-(define (wait-for-local-port port)
-  (let loop ([attempts 1])
-    (sync (system-idle-evt))
-    (with-handlers ([exn:fail?
-                     (lambda (e)
-                       (if (> attempts 99)
-                           (raise e)
-                           (loop (add1 attempts))))])
-      (define-values (in out)
-        (tcp-connect "127.0.0.1" port))
-      (close-output-port out)
-      (close-input-port in))))
+(define here (path-only (syntax-source #'here)))
 
 (define all-e2e-tests
   (make-test-suite
    "e2e"
 
    (for/list ([test-path (in-list (directory-list here))]
-              [port (in-naturals 9111)]
               #:when (directory-exists? test-path)
               #:unless (equal? #"compiled" (path->bytes test-path)))
      (define server-mod-path (build-path test-path "server.rkt"))
      (define tests-mod-path (build-path test-path "tests.rkt"))
-     (define stopper #f)
+     (define stop-box (box void))
+     (define port-box (box #f))
      (make-test-suite
       (path->string (file-name-from-path test-path))
       #:before
-      (lambda _
-        (define start
-          (dynamic-require server-mod-path 'start))
-
-        (set! stopper (start port))
-        (wait-for-local-port port))
+      (lambda ()
+        (define start (dynamic-require server-mod-path 'start))
+        (let-values ([(stop port) (start)])
+          (set-box! stop-box stop)
+          (set-box! port-box port)))
       #:after
-      (lambda _
-        (stopper))
-
+      (lambda ()
+        ((unbox stop-box)))
       (let ([make-tests (dynamic-require tests-mod-path 'make-tests)])
-        (list (make-tests port)))))))
+        (list
+         (make-tests
+          (λ () (unbox port-box))
+          (λ () (unbox stop-box)))))))))
 
 (module+ test
   (require rackunit/text-ui)

web-server-test/tests/web-server/e2e/echo/server.rkt

@@ -1,6 +1,7 @@
 #lang racket/base
 
-(require web-server/servlet
+(require racket/async-channel
+         web-server/servlet
          web-server/servlet-dispatch
          web-server/web-server)
 
@@ -15,7 +16,16 @@
    (lambda (out)
      (display msg out))))
 
-(define (start port)
-  (serve
-   #:port port
-   #:dispatch (dispatch/servlet echo)))
+(define (start)
+  (define confirmation-ch
+    (make-async-channel))
+  (define stop
+    (serve
+     #:port 0
+     #:dispatch (dispatch/servlet echo)
+     #:confirmation-channel confirmation-ch))
+  (define port-or-exn
+    (sync confirmation-ch))
+  (when (exn:fail? port-or-exn)
+    (raise port-or-exn))
+  (values stop port-or-exn))

web-server-test/tests/web-server/e2e/echo/tests.rkt

@@ -9,9 +9,9 @@
 (define get-response
   (compose1 port->string get-pure-port string->url))
 
-(define (make-tests port)
+(define (make-tests get-port _get-stop)
   (define (make-uri [path "/"])
-    (format "http://127.0.0.1:~a/~a" port path))
+    (format "http://127.0.0.1:~a/~a" (get-port) path))
 
   (test-suite
    "echo"