diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml
index a5b06266..d4b264ed 100644
--- a/.github/workflows/ci.yml
+++ b/.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
diff --git a/web-server-doc/web-server/scribblings/safety-limits.scrbl b/web-server-doc/web-server/scribblings/safety-limits.scrbl
index 3cec9715..7042969e 100644
--- a/web-server-doc/web-server/scribblings/safety-limits.scrbl
+++ b/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}]
}
diff --git a/web-server-lib/info.rkt b/web-server-lib/info.rkt
index 3b4cdd61..44b53fe8 100644
--- a/web-server-lib/info.rkt
+++ b/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))
diff --git a/web-server-lib/web-server/private/dispatch-server-with-connect-unit.rkt b/web-server-lib/web-server/private/dispatch-server-with-connect-unit.rkt
index dc93288d..7fcec9db 100644
--- a/web-server-lib/web-server/private/dispatch-server-with-connect-unit.rkt
+++ b/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
diff --git a/web-server-lib/web-server/safety-limits.rkt b/web-server-lib/web-server/safety-limits.rkt
index 08cefd07..b8489b0c 100644
--- a/web-server-lib/web-server/safety-limits.rkt
+++ b/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)
diff --git a/web-server-test/tests/web-server/all-web-server-tests.rkt b/web-server-test/tests/web-server/all-web-server-tests.rkt
index 81ad5a50..eadc8b8b 100644
--- a/web-server-test/tests/web-server/all-web-server-tests.rkt
+++ b/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))
diff --git a/web-server-test/tests/web-server/e2e/README.md b/web-server-test/tests/web-server/e2e/README.md
index 4666dff9..00a8a754 100644
--- a/web-server-test/tests/web-server/e2e/README.md
+++ b/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`.
diff --git a/web-server-test/tests/web-server/e2e/all-e2e-tests.rkt b/web-server-test/tests/web-server/e2e/all-e2e-tests.rkt
index 52eca5ee..21db0347 100644
--- a/web-server-test/tests/web-server/e2e/all-e2e-tests.rkt
+++ b/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)
diff --git a/web-server-test/tests/web-server/e2e/echo/server.rkt b/web-server-test/tests/web-server/e2e/echo/server.rkt
index 93f281c7..8e438c4e 100644
--- a/web-server-test/tests/web-server/e2e/echo/server.rkt
+++ b/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))
diff --git a/web-server-test/tests/web-server/e2e/echo/tests.rkt b/web-server-test/tests/web-server/e2e/echo/tests.rkt
index 00bb8b44..c407e4e8 100644
--- a/web-server-test/tests/web-server/e2e/echo/tests.rkt
+++ b/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"
diff --git a/web-server-test/tests/web-server/e2e/file-upload/server.rkt b/web-server-test/tests/web-server/e2e/file-upload/server.rkt
index 20a88a22..ceccef5e 100644
--- a/web-server-test/tests/web-server/e2e/file-upload/server.rkt
+++ b/web-server-test/tests/web-server/e2e/file-upload/server.rkt
@@ -1,10 +1,11 @@
#lang racket/base
(require openssl/sha1
+ racket/async-channel
racket/port
+ web-server/safety-limits
web-server/servlet
web-server/servlet-dispatch
- web-server/safety-limits
web-server/web-server)
(provide start)
@@ -18,15 +19,24 @@
(for ([h (in-list hashes)])
(displayln h out)))))
-(define (start port)
+(define (start)
;; We're testing file limits and those end up raising exceptions in
;; the request-handling threads which get reported to stderr so we
;; need to drop those messages in order for drdr not to fail.
(parameterize ([current-error-port (open-output-nowhere)])
- (serve
- #:port port
- #:dispatch (dispatch/servlet file-upload)
- #:safety-limits (make-safety-limits
- #:max-form-data-files 2
- #:max-form-data-file-length 500
- #:form-data-file-memory-threshold 250))))
+ (define confirmation-ch
+ (make-async-channel))
+ (define stop
+ (serve
+ #:port 0
+ #:dispatch (dispatch/servlet file-upload)
+ #:confirmation-channel confirmation-ch
+ #:safety-limits (make-safety-limits
+ #:max-form-data-files 2
+ #:max-form-data-file-length 500
+ #:form-data-file-memory-threshold 250)))
+ (define port-or-exn
+ (sync confirmation-ch))
+ (when (exn:fail? port-or-exn)
+ (raise port-or-exn))
+ (values stop port-or-exn)))
diff --git a/web-server-test/tests/web-server/e2e/file-upload/tests.rkt b/web-server-test/tests/web-server/e2e/file-upload/tests.rkt
index 96d3e195..fbb70eb9 100644
--- a/web-server-test/tests/web-server/e2e/file-upload/tests.rkt
+++ b/web-server-test/tests/web-server/e2e/file-upload/tests.rkt
@@ -1,20 +1,18 @@
#lang racket/base
-(require net/url
- openssl/sha1
- racket/list
+(require openssl/sha1
racket/port
+ racket/random
racket/string
racket/tcp
- racket/random
rackunit)
(provide make-tests)
-(define (make-tests port)
+(define (make-tests get-port _get-stop)
(define (upload-files . ins)
(define-values (in out)
- (tcp-connect "127.0.0.1" port))
+ (tcp-connect "127.0.0.1" (get-port)))
(define boundary
(sha1-bytes (open-input-bytes (crypto-random-bytes 32))))
diff --git a/web-server-test/tests/web-server/e2e/graceful-shutdown/server.rkt b/web-server-test/tests/web-server/e2e/graceful-shutdown/server.rkt
new file mode 100644
index 00000000..c84a7e75
--- /dev/null
+++ b/web-server-test/tests/web-server/e2e/graceful-shutdown/server.rkt
@@ -0,0 +1,35 @@
+#lang racket/base
+
+(require racket/async-channel
+ web-server/safety-limits
+ web-server/servlet
+ web-server/servlet-dispatch
+ web-server/web-server)
+
+(provide start)
+
+(define (app _req)
+ (response/output
+ (lambda (out)
+ (for ([idx (in-range 5)])
+ (displayln idx out)
+ (sleep 1)))))
+
+(define (start)
+ (define confirmation-ch
+ (make-async-channel))
+ (define stop
+ (serve
+ #:port 0
+ #:dispatch (dispatch/servlet app)
+ #:confirmation-channel confirmation-ch
+ #:safety-limits
+ (make-safety-limits
+ #:max-concurrent 1
+ #:max-waiting 10
+ #:shutdown-grace-period 6)))
+ (define port-or-exn
+ (sync confirmation-ch))
+ (when (exn:fail? port-or-exn)
+ (raise port-or-exn))
+ (values stop port-or-exn))
diff --git a/web-server-test/tests/web-server/e2e/graceful-shutdown/tests.rkt b/web-server-test/tests/web-server/e2e/graceful-shutdown/tests.rkt
new file mode 100644
index 00000000..c356005e
--- /dev/null
+++ b/web-server-test/tests/web-server/e2e/graceful-shutdown/tests.rkt
@@ -0,0 +1,19 @@
+#lang racket/base
+
+(require net/http-client
+ racket/port
+ rackunit)
+
+(provide make-tests)
+
+(define (make-tests get-port get-stop)
+ (test-suite
+ "graceful-shutdown"
+
+ (test-case "waits for in-progress connections on stop"
+ (define hc (http-conn-open "127.0.0.1" #:port (get-port)))
+ (define-values (status _headers in)
+ (http-conn-sendrecv! hc "/"))
+ ((get-stop))
+ (check-equal? status #"HTTP/1.1 200 OK")
+ (check-equal? (port->bytes in) #"0\n1\n2\n3\n4\n"))))
diff --git a/web-server-test/tests/web-server/e2e/head/server.rkt b/web-server-test/tests/web-server/e2e/head/server.rkt
index 43f938af..2584bbe6 100644
--- a/web-server-test/tests/web-server/e2e/head/server.rkt
+++ b/web-server-test/tests/web-server/e2e/head/server.rkt
@@ -1,17 +1,27 @@
#lang racket/base
-(require web-server/servlet
+(require racket/async-channel
+ web-server/servlet
web-server/servlet-dispatch
web-server/web-server)
(provide start)
-(define (start port)
- (serve
- #:port port
- #:dispatch (dispatch/servlet
- (lambda (_req)
- (response/output
- #:headers (list (make-header #"X-Example" #"Found"))
- (lambda (out)
- (displayln "hello" out)))))))
+(define (start)
+ (define confirmation-ch
+ (make-async-channel))
+ (define stop
+ (serve
+ #:port 0
+ #:dispatch (dispatch/servlet
+ (lambda (_req)
+ (response/output
+ #:headers (list (make-header #"X-Example" #"Found"))
+ (lambda (out)
+ (displayln "hello" out)))))
+ #: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))
diff --git a/web-server-test/tests/web-server/e2e/head/tests.rkt b/web-server-test/tests/web-server/e2e/head/tests.rkt
index 0bf6a1db..f925d2ca 100644
--- a/web-server-test/tests/web-server/e2e/head/tests.rkt
+++ b/web-server-test/tests/web-server/e2e/head/tests.rkt
@@ -5,12 +5,12 @@
(provide make-tests)
-(define (make-tests port)
+(define (make-tests get-port _get-stop)
;; net/url and net/http-client both ignore the body of HEAD requests
;; if present so we can't use them to test this.
(define (request method path)
(define-values (in out)
- (tcp-connect "127.0.0.1" port))
+ (tcp-connect "127.0.0.1" (get-port)))
(display (format "~a ~a HTTP/1.1\r\n" method path) out)
(display "\r\n" out)
diff --git a/web-server-test/tests/web-server/e2e/json/server.rkt b/web-server-test/tests/web-server/e2e/json/server.rkt
index 3ea39d4c..697095e4 100644
--- a/web-server-test/tests/web-server/e2e/json/server.rkt
+++ b/web-server-test/tests/web-server/e2e/json/server.rkt
@@ -1,10 +1,11 @@
#lang racket/base
(require json
+ racket/async-channel
racket/port
+ web-server/safety-limits
web-server/servlet
web-server/servlet-dispatch
- web-server/safety-limits
web-server/web-server)
(provide start)
@@ -21,7 +22,7 @@
(lambda (out)
(write-json e out))))
-(define (all-books req)
+(define (all-books _req)
(response/json
(for/list ([book (in-list (unbox *all-books*))])
(hasheq 'title (book-title book)
@@ -49,13 +50,22 @@
[("books") #:method "post" add-book]
[("books") all-books]))
-(define (start port)
+(define (start)
;; One of the tests tries to send invalid JSON, which causes the
;; request handler to throw an exception, which would normally get
;; logged to stderr. This swallows that logging to avoid failing drdr.
(parameterize ([current-error-port (open-output-nowhere)])
- (serve
- #:port port
- #:dispatch (dispatch/servlet go)
- #:safety-limits (make-safety-limits
- #:max-request-body-length 255))))
+ (define confirmation-ch
+ (make-async-channel))
+ (define stop
+ (serve
+ #:port 0
+ #:dispatch (dispatch/servlet go)
+ #:confirmation-channel confirmation-ch
+ #:safety-limits (make-safety-limits
+ #:max-request-body-length 255)))
+ (define port-or-exn
+ (sync confirmation-ch))
+ (when (exn:fail? port-or-exn)
+ (raise port-or-exn))
+ (values stop port-or-exn)))
diff --git a/web-server-test/tests/web-server/e2e/json/tests.rkt b/web-server-test/tests/web-server/e2e/json/tests.rkt
index 4a9db684..22ed9f41 100644
--- a/web-server-test/tests/web-server/e2e/json/tests.rkt
+++ b/web-server-test/tests/web-server/e2e/json/tests.rkt
@@ -7,9 +7,9 @@
(provide make-tests)
-(define (make-tests port)
+(define (make-tests get-port _get-stop)
(define (make-url [path "/"])
- (string->url (format "http://127.0.0.1:~a/~a" port path)))
+ (string->url (format "http://127.0.0.1:~a/~a" (get-port) path)))
(define (get-books)
(read-json (get-pure-port (make-url "books"))))
diff --git a/web-server-test/tests/web-server/e2e/max-concurrent/server.rkt b/web-server-test/tests/web-server/e2e/max-concurrent/server.rkt
index a3d965e4..4190ef8e 100644
--- a/web-server-test/tests/web-server/e2e/max-concurrent/server.rkt
+++ b/web-server-test/tests/web-server/e2e/max-concurrent/server.rkt
@@ -1,6 +1,7 @@
#lang racket/base
-(require web-server/safety-limits
+(require racket/async-channel
+ web-server/safety-limits
web-server/servlet
web-server/servlet-dispatch
web-server/web-server)
@@ -12,10 +13,19 @@
(lambda (out)
(display "ok" out))))
-(define (start port)
- (serve
- #:port port
- #:dispatch (dispatch/servlet app)
- #:safety-limits (make-safety-limits
- #:max-concurrent 1
- #:max-waiting 10)))
+(define (start)
+ (define confirmation-ch
+ (make-async-channel))
+ (define stop
+ (serve
+ #:port 0
+ #:dispatch (dispatch/servlet app)
+ #:confirmation-channel confirmation-ch
+ #:safety-limits (make-safety-limits
+ #:max-concurrent 1
+ #:max-waiting 10)))
+ (define port-or-exn
+ (sync confirmation-ch))
+ (when (exn:fail? port-or-exn)
+ (raise port-or-exn))
+ (values stop port-or-exn))
diff --git a/web-server-test/tests/web-server/e2e/max-concurrent/tests.rkt b/web-server-test/tests/web-server/e2e/max-concurrent/tests.rkt
index 18f00846..4c3d84b8 100644
--- a/web-server-test/tests/web-server/e2e/max-concurrent/tests.rkt
+++ b/web-server-test/tests/web-server/e2e/max-concurrent/tests.rkt
@@ -7,7 +7,7 @@
(provide make-tests)
-(define (make-tests port)
+(define (make-tests get-port _get-stop)
(define-check (check-concurrent-requests n min-successes min-failures)
(let ([sema (make-semaphore)])
(define result-ch (make-channel))
@@ -17,7 +17,7 @@
(lambda ()
(with-handlers ([(λ (_) #t)
(λ (e) (channel-put result-ch e))])
- (define conn (http-conn-open "127.0.0.1" #:port port))
+ (define conn (http-conn-open "127.0.0.1" #:port (get-port)))
(semaphore-wait sema)
(define-values (line _headers in)
(http-conn-sendrecv! conn "/"))
@@ -45,7 +45,7 @@
"sequential requests"
(for ([_ (in-range 10)])
(define-values (_line _headers in)
- (http-sendrecv "127.0.0.1" #:port port "/"))
+ (http-sendrecv "127.0.0.1" #:port (get-port) "/"))
(check-equal? (port->string in) "ok")))
(test-suite
diff --git a/web-server-test/tests/web-server/e2e/read-write/server.rkt b/web-server-test/tests/web-server/e2e/read-write/server.rkt
index 0c06e8a6..d1141f80 100644
--- a/web-server-test/tests/web-server/e2e/read-write/server.rkt
+++ b/web-server-test/tests/web-server/e2e/read-write/server.rkt
@@ -1,9 +1,10 @@
#lang racket/base
-(require racket/port
+(require racket/async-channel
+ racket/port
+ web-server/safety-limits
web-server/servlet
web-server/servlet-dispatch
- web-server/safety-limits
web-server/web-server)
(provide start)
@@ -13,11 +14,20 @@
(lambda (out)
(display (request-post-data/raw req) out))))
-(define (start port)
+(define (start)
(parameterize ([current-error-port (open-output-nowhere)])
- (serve
- #:port port
- #:dispatch (dispatch/servlet read-write)
- #:safety-limits (make-safety-limits
- #:request-read-timeout 1
- #:response-send-timeout 1))))
+ (define confirmation-ch
+ (make-async-channel))
+ (define stop
+ (serve
+ #:port 0
+ #:dispatch (dispatch/servlet read-write)
+ #:confirmation-channel confirmation-ch
+ #:safety-limits (make-safety-limits
+ #:request-read-timeout 1
+ #:response-send-timeout 1)))
+ (define port-or-exn
+ (sync confirmation-ch))
+ (when (exn:fail? port-or-exn)
+ (raise port-or-exn))
+ (values stop port-or-exn)))
diff --git a/web-server-test/tests/web-server/e2e/read-write/tests.rkt b/web-server-test/tests/web-server/e2e/read-write/tests.rkt
index 73272ff3..2ff889f1 100644
--- a/web-server-test/tests/web-server/e2e/read-write/tests.rkt
+++ b/web-server-test/tests/web-server/e2e/read-write/tests.rkt
@@ -11,7 +11,7 @@
(and (exn:fail:network? e)
(equal? (exn:fail:network:errno-errno e) '(32 . posix))))
-(define (make-tests port)
+(define (make-tests get-port _get-stop)
(test-suite
"read-write"
@@ -20,7 +20,7 @@
"hello world"
(port->string
(post-pure-port
- (string->url (format "http://127.0.0.1:~a" port))
+ (string->url (format "http://127.0.0.1:~a" (get-port)))
#"hello world"))))
(test-exn
@@ -32,8 +32,8 @@
;; custom plumber seems to fix that problem.
(parameterize ([current-plumber (make-plumber)])
(define-values (in out)
- (tcp-connect "127.0.0.1" port))
-
+ (tcp-connect "127.0.0.1" (get-port)))
+ (tcp-abandon-port in)
(parameterize ([current-output-port out])
(for ([c (in-string "POST / HTTP/1.1\r\n")])
(display c)
diff --git a/web-server-test/tests/web-server/e2e/tls/server.rkt b/web-server-test/tests/web-server/e2e/tls/server.rkt
index a99753be..1a06d016 100644
--- a/web-server-test/tests/web-server/e2e/tls/server.rkt
+++ b/web-server-test/tests/web-server/e2e/tls/server.rkt
@@ -1,6 +1,7 @@
#lang racket/base
-(require racket/port
+(require racket/async-channel
+ racket/port
web-server/servlet
web-server/servlet-dispatch
web-server/web-server)
@@ -11,15 +12,26 @@
(simplify-path
(build-path (syntax-source #'here) 'up)))
-(define (hello req)
+(define (hello _req)
(response/output
(lambda (out)
(display "success!" out))))
-(define (start port)
+(define (start)
(parameterize ([current-error-port (open-output-nowhere)])
- (serve
- #:port port
- #:dispatch (dispatch/servlet hello)
- #:dispatch-server-connect@ (make-ssl-connect@ (build-path here "cert.pem")
- (build-path here "key.pem")))))
+ (define confirmation-ch
+ (make-async-channel))
+ (define stop
+ (serve
+ #:port 0
+ #:dispatch (dispatch/servlet hello)
+ #:dispatch-server-connect@
+ (make-ssl-connect@
+ (build-path here "cert.pem")
+ (build-path here "key.pem"))
+ #: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)))
diff --git a/web-server-test/tests/web-server/e2e/tls/tests.rkt b/web-server-test/tests/web-server/e2e/tls/tests.rkt
index acefeae8..f52158ed 100644
--- a/web-server-test/tests/web-server/e2e/tls/tests.rkt
+++ b/web-server-test/tests/web-server/e2e/tls/tests.rkt
@@ -6,11 +6,11 @@
(provide make-tests)
-(define (make-tests port)
+(define (make-tests get-port _get-stop)
(test-suite
"tls"
(test-equal?
"can get data"
- (port->string (get-pure-port (string->url (format "https://127.0.0.1:~a" port))))
+ (port->string (get-pure-port (string->url (format "https://127.0.0.1:~a" (get-port)))))
"success!")))
diff --git a/web-server-test/tests/web-server/pr/gh3/main.rkt b/web-server-test/tests/web-server/pr/gh3/main.rkt
index be3afadd..7e1d4129 100644
--- a/web-server-test/tests/web-server/pr/gh3/main.rkt
+++ b/web-server-test/tests/web-server/pr/gh3/main.rkt
@@ -1,38 +1,45 @@
#lang racket/base
-(require racket/runtime-path
+
+(require net/http-client
+ racket/async-channel
racket/port
- racket/list
- web-server/servlet
- net/http-client
- web-server/servlet-env)
+ racket/runtime-path
+ version/utils
+ web-server/http
+ web-server/servlet-dispatch
+ web-server/web-server)
-(define-runtime-path here ".")
+(define-runtime-path private-key.pem
+ "private-key.pem")
+(define-runtime-path server-cert.pem
+ "server-cert.pem")
(module+ test
(require rackunit)
-
- (define-values (pipe-i pipe-o) (make-pipe))
-
- (define server-t
- (parameterize ([current-output-port pipe-o])
- (thread
- (λ ()
- (serve/servlet (lambda (req) (response/xexpr `(html (body (h1 "Hello")))))
- #:launch-browser? #f
- #:port 0
- #:listen-ip #f
- #:ssl? #t
- #:ssl-cert (build-path here "server-cert.pem")
- #:ssl-key (build-path here "private-key.pem")
- #:servlet-regexp #rx"")))))
- (define the-port
- (string->number
- (second
- (regexp-match #rx"localhost:([0-9]+).$" (read-line pipe-i)))))
-
- (define-values (status headers body)
- (http-sendrecv "localhost" "/" #:port the-port #:ssl? #t))
-
- (check-equal? status #"HTTP/1.1 200 OK")
- (check-equal? (port->bytes body) #"Hello
"))
+ ;; Old versions of Racket don't work well with recent versions of
+ ;; OpenSSL found in CI. So, skip this test for older Rackets.
+ (unless (versionbytes body) #"Hello
"))
+ (stop)))
diff --git a/web-server-test/tests/web-server/serve-tests.rkt b/web-server-test/tests/web-server/serve-tests.rkt
new file mode 100644
index 00000000..11b45789
--- /dev/null
+++ b/web-server-test/tests/web-server/serve-tests.rkt
@@ -0,0 +1,156 @@
+#lang racket/base
+
+(require net/http-client
+ racket/async-channel
+ racket/port
+ racket/promise
+ rackunit
+ version/utils
+ web-server/http
+ web-server/safety-limits
+ web-server/servlet-dispatch
+ web-server/web-server)
+
+(provide
+ serve-tests)
+
+(define (call-with-web-server
+ #:limits [limits (make-safety-limits #:shutdown-grace-period 5)]
+ handler proc)
+ (define confirmation-ch
+ (make-async-channel))
+ (define stop
+ (serve
+ #:port 0
+ #:dispatch (dispatch/servlet handler)
+ #:confirmation-channel confirmation-ch
+ #:safety-limits limits))
+ (define port-or-exn
+ (sync confirmation-ch))
+ (when (exn:fail? port-or-exn)
+ (raise port-or-exn))
+ (dynamic-wind
+ void
+ (lambda ()
+ (proc port-or-exn stop))
+ (lambda ()
+ (stop))))
+
+(define-check (check-duration proc lo hi timeout)
+ (define promise
+ (delay/thread
+ (define-values (_ _cpu-time real-time _gc-time)
+ (time-apply proc null))
+ (/ real-time 1000)))
+ (define real-time
+ (sync/timeout
+ timeout
+ (handle-evt
+ promise
+ (lambda (_)
+ (force promise)))))
+ (unless real-time
+ (fail-check "timed out"))
+ (check-true
+ (real-time . >= . lo)
+ (format "took less than ~a seconds to run" lo))
+ (check-true
+ (real-time . <= . hi)
+ (format "took more than ~a seconds to run" hi)))
+
+(define serve-tests
+ (test-suite
+ "serve"
+
+ (test-suite
+ "graceful shutdown"
+
+ (test-case "stops immediately if there are no connections"
+ (call-with-web-server
+ (lambda (_req)
+ (response/empty))
+ (lambda (_port stop)
+ (check-duration stop 0 1 5))))
+
+ ;; On versions prior to [1], net/http-client writes to standard
+ ;; error when reading from the connection's input port goes wrong.
+ ;; This makes raco test fail in --drdr mode, so avoid running these
+ ;; tests on versions before 8.17.0.6.
+ ;;
+ ;; [1]: https://github.com/racket/racket/pull/5296
+ (when (version<=? "8.17.0.6" (version))
+ (test-case "waits for in-progress requests to finish"
+ (call-with-web-server
+ (lambda (_req)
+ (response/output
+ (lambda (out)
+ (for ([idx (in-range 2)])
+ (displayln idx out)
+ (sleep 1)))))
+ (lambda (port stop)
+ (define hc (http-conn-open "127.0.0.1" #:port port))
+ (define-values (status _headers in)
+ (http-conn-sendrecv! hc "/"))
+ (check-equal? status #"HTTP/1.1 200 OK")
+ (check-duration stop 2 6 6)
+ (check-equal? (port->bytes in) #"0\n1\n"))))
+
+ (test-case "stops when in-progress requests stop"
+ (call-with-web-server
+ (lambda (_req)
+ (response/output
+ (lambda (out)
+ (for ([idx (in-range 10)])
+ (displayln idx out)
+ (sleep 1)))))
+ (lambda (port stop)
+ (define hc (http-conn-open "127.0.0.1" #:port port))
+ (define-values (status _headers in)
+ (http-conn-sendrecv! hc "/"))
+ (check-equal? status #"HTTP/1.1 200 OK")
+ (thread
+ (lambda ()
+ (read-line in)
+ (close-input-port in)
+ (http-conn-close! hc)))
+ (check-duration stop 1 3 5))))
+
+ (test-case "kills the server if stop is called twice"
+ (define started?-sema
+ (make-semaphore))
+ (call-with-web-server
+ (lambda (_req)
+ (response/output
+ (lambda (out)
+ (displayln "start" out)
+ (semaphore-post started?-sema)
+ (sleep 100)
+ (displayln "end" out))))
+ (lambda (port stop)
+ (define hc (http-conn-open "127.0.0.1" #:port port))
+ (define-values (status _headers in)
+ (http-conn-sendrecv! hc "/"))
+ (check-equal? status #"HTTP/1.1 200 OK")
+ (define data-promise
+ (delay/thread
+ (with-handlers ([(lambda (e)
+ (and (exn:fail? e)
+ (regexp-match? #rx"input port is closed" (exn-message e))))
+ (lambda (_)
+ #"")])
+ (port->bytes in))))
+ (semaphore-wait started?-sema)
+ (define stop-thds
+ (for/list ([_ (in-range 2)])
+ (thread stop)))
+ (check-duration
+ (lambda ()
+ (for-each thread-wait stop-thds))
+ 0 1 2)
+ (check-match
+ (force data-promise)
+ (or #"" #"start\n")))))))))
+
+(module+ test
+ (require rackunit/text-ui)
+ (run-tests serve-tests))