Make web server test find free port.

1 files changed, 31 insertions, 13 deletions

diff --git a/tests/web-server.scm b/tests/web-server.scm
index 73d34317..837ca3ab 100644
--- a/tests/web-server.scm
+++ b/tests/web-server.scm
@@ -1,6 +1,10 @@
 ;;; Commentary:
 ;; Checks that HTTP server can start correctly, and that at least some
 ;; endpoints return correct information.
+;;
+;; NOTE This test, when ran in as `tests/run-tests --only web-server.scm'
+;; segfaults on Guile 2.2.7, but not on Guile 3.0.8. This doesn't happen
+;; when it's run as one of all tests.
 ;;; Code:
 
 (((calp server routes) make-make-routes)
@@ -10,24 +14,38 @@
  ((hnh util) let*)
  ((web response) response-code response-location)
  ((web uri) build-uri uri-path)
- ((guile) AF_INET))
+ ((guile)
+  socket inet-pton bind make-socket-address setsockopt
+  AF_INET PF_INET SOL_SOCKET SO_REUSEADDR SOCK_STREAM
+  )
+ )
+
 
-;; TODO find some free address.
-(define port 8090)
 (define host "127.8.9.5")
+(define sock (socket PF_INET SOCK_STREAM 0))
+(setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
+
+(define-values (port sock)
+ (let ((addr (inet-pton AF_INET host)))
+   (let loop ((port 8090))
+     (catch 'system-error
+       (lambda ()
+         (bind sock (make-socket-address AF_INET addr port))
+         (values port sock))
+       (lambda (err proc fmt args data)
+         (if (and (not (null? data))
+                  ;; errno address already in use
+                  (= 98 (car data)))
+             (loop (1+ port))
+             ;; rethrow
+             (throw err fmt args data)))))))
 
 (define server-thread
   (call-with-new-thread
-   (lambda ()
-     (run-server (make-make-routes)
-                 'http
-                 `(family: ,AF_INET
-                           host: ,host
-                           port: ,port
-                           ))
-     ;; This test should always fail, but should never be run
-     (test-assert "Server returned unexpectedly" #f)
-     )))
+    (lambda ()
+      (run-server (make-make-routes) 'http `(socket: ,sock))
+      ;; This test should always fail, but should never be run
+      (test-assert "Server returned unexpectedly" #f))))
 
 (let* ((response body (http-get (build-uri 'http host: host port: port))))
   (test-eqv "Basic connect" 200 (response-code response)))