From: Robert Pluim <rpluim@gmail.com>
Date: Fri, 20 Jun 2025 10:09:14 +0000 (+0200)
Subject: Make tls tests use random port
X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=9926e759be4160f00811b4809484a391da226ee1;p=emacs.git

Make tls tests use random port

* test/lisp/net/network-stream-tests.el (server-process-filter):
Remove 'message' call.
(make-tls-server): Try random ports until we find one that's
unused and use it.  Adjust all callers.

(cherry picked from commit 1560e9bf66597b3bf7f389ed22ad4524ca89d4e2)
---

diff --git a/test/lisp/net/network-stream-tests.el b/test/lisp/net/network-stream-tests.el
index d868562f5cf..41ca0264907 100644
--- a/test/lisp/net/network-stream-tests.el
+++ b/test/lisp/net/network-stream-tests.el
@@ -125,7 +125,6 @@
   )
 
 (defun server-process-filter (proc string)
-  (message "Received %s" string)
   (let ((prev (process-get proc 'previous-string)))
     (when prev
       (setq string (concat prev string))
@@ -244,36 +243,52 @@
       (should (equal (buffer-string) "foo\n")))
     (delete-process server)))
 
-(defun make-tls-server (port)
-  (start-process "gnutls" (generate-new-buffer "*tls*")
-                 "gnutls-serv" "--http"
-                 "--x509keyfile"
-                 (ert-resource-file "key.pem")
-                 "--x509certfile"
-                 (ert-resource-file "cert.pem")
-                 "--port" (format "%s" port)))
+(defun make-tls-server (&optional params)
+  (catch 'server
+    (let (port
+          proc)
+      (while t
+        (setq port (+ 20000 (random 45535))
+              proc (apply #'start-process
+                          "gnutls" (generate-new-buffer "*tls*")
+                          "gnutls-serv" "--http"
+                          "--x509keyfile"
+                          (ert-resource-file "key.pem")
+                          "--x509certfile"
+                          (ert-resource-file "cert.pem")
+                          "--port" (format "%s" port)
+                          params))
+        (while (not (eq (process-status proc) 'run))
+          (sit-for 0.1))
+        (with-current-buffer (process-buffer proc)
+          (when (eq
+                 (catch 'status
+                   (while t
+                     (goto-char (point-min))
+                     (when (search-forward (format "port %s..." port) nil t)
+                       (if (looking-at "done")
+                           (throw 'status 'done))
+                       (if (looking-at "bind() failed")
+                           (throw 'status 'failed)))
+                     (sit-for 0.1)))
+                 'done)
+            (throw 'server (cons proc port))))
+        (delete-process proc)))))
 
 (ert-deftest connect-to-tls-ipv4-wait ()
   (skip-unless (executable-find "gnutls-serv"))
   (skip-unless (gnutls-available-p))
-  (let ((server (make-tls-server 44332))
-        (times 0)
-        proc status)
+  (let* ((s (make-tls-server))
+         (server (car s))
+         (port (cdr s))
+         proc status)
     (unwind-protect
         (progn
-          (sleep-for 1)
-          (with-current-buffer (process-buffer server)
-            (message "gnutls-serv: %s" (buffer-string)))
-
-          ;; It takes a while for gnutls-serv to start.
-          (while (and (null (ignore-errors
-                              (setq proc (make-network-process
-                                          :name "bar"
-                                          :buffer (generate-new-buffer "*foo*")
-                                          :host "localhost"
-                                          :service 44332))))
-                      (< (setq times (1+ times)) 10))
-            (sit-for 0.1))
+          (setq proc (make-network-process
+                      :name "bar"
+                      :buffer (generate-new-buffer "*foo*")
+                      :host "localhost"
+                      :service port))
           (should proc)
           (gnutls-negotiate :process proc
                             :type 'gnutls-x509pki
@@ -294,33 +309,25 @@
 (ert-deftest connect-to-tls-ipv4-nowait ()
   (skip-unless (executable-find "gnutls-serv"))
   (skip-unless (gnutls-available-p))
-  (let ((server (make-tls-server 44331))
-        (times 0)
-        (network-security-level 'low)
-        proc status)
+  (let* ((s (make-tls-server))
+         (server (car s))
+         (port (cdr s))
+         (times 0)
+         (network-security-level 'low)
+         proc status)
     (unwind-protect
         (progn
-          (sleep-for 1)
-          (with-current-buffer (process-buffer server)
-            (message "gnutls-serv: %s" (buffer-string)))
-
-          ;; It takes a while for gnutls-serv to start.
-          (while (and (null (ignore-errors
-                              (setq proc (make-network-process
-                                          :name "bar"
-                                          :buffer (generate-new-buffer "*foo*")
-                                          :nowait t
-                                          :family 'ipv4
-                                          :tls-parameters
-                                          (cons 'gnutls-x509pki
-                                                (gnutls-boot-parameters
-                                                 :hostname "localhost"))
-                                          :host "localhost"
-                                          :service 44331))))
-                      (< (setq times (1+ times)) 10))
-            (sit-for 0.1))
-          (should proc)
-          (setq times 0)
+          (setq proc (make-network-process
+                      :name "bar"
+                      :buffer (generate-new-buffer "*foo*")
+                      :nowait t
+                      :family 'ipv4
+                      :tls-parameters
+                      (cons 'gnutls-x509pki
+                            (gnutls-boot-parameters
+                             :hostname "localhost"))
+                      :host "localhost"
+                      :service port))
           (while (and (eq (process-status proc) 'connect)
                       (< (setq times (1+ times)) 10))
             (sit-for 0.1))
@@ -339,33 +346,26 @@
   (skip-unless (gnutls-available-p))
   (skip-when (eq system-type 'windows-nt))
   (skip-unless (featurep 'make-network-process '(:family ipv6)))
-  (let ((server (make-tls-server 44333))
-        (times 0)
-        (network-security-level 'low)
-        proc status)
+  (let* ((s (make-tls-server))
+         (server (car s))
+         (port (cdr s))
+         (times 0)
+         (network-security-level 'low)
+         proc status)
     (unwind-protect
         (progn
-          (sleep-for 1)
-          (with-current-buffer (process-buffer server)
-            (message "gnutls-serv: %s" (buffer-string)))
-
-          ;; It takes a while for gnutls-serv to start.
-          (while (and (null (ignore-errors
-                              (setq proc (make-network-process
-                                          :name "bar"
-                                          :buffer (generate-new-buffer "*foo*")
-                                          :family 'ipv6
-                                          :nowait t
-                                          :tls-parameters
-                                          (cons 'gnutls-x509pki
-                                                (gnutls-boot-parameters
-                                                 :hostname "localhost"))
-                                          :host "::1"
-                                          :service 44333))))
-                      (< (setq times (1+ times)) 10))
-            (sit-for 0.1))
+          (setq proc (make-network-process
+                      :name "bar"
+                      :buffer (generate-new-buffer "*foo*")
+                      :family 'ipv6
+                      :nowait t
+                      :tls-parameters
+                      (cons 'gnutls-x509pki
+                            (gnutls-boot-parameters
+                             :hostname "localhost"))
+                      :host "::1"
+                      :service port))
           (should proc)
-          (setq times 0)
           (while (and (eq (process-status proc) 'connect)
                       (< (setq times (1+ times)) 10))
             (sit-for 0.1))
@@ -382,27 +382,20 @@
 (ert-deftest open-network-stream-tls-wait ()
   (skip-unless (executable-find "gnutls-serv"))
   (skip-unless (gnutls-available-p))
-  (let ((server (make-tls-server 44334))
-        (times 0)
-        (network-security-level 'low)
-        proc status)
+  (let* ((s (make-tls-server))
+         (server (car s))
+         (port (cdr s))
+         (network-security-level 'low)
+         proc status)
     (unwind-protect
         (progn
-          (sleep-for 1)
-          (with-current-buffer (process-buffer server)
-            (message "gnutls-serv: %s" (buffer-string)))
-
-          ;; It takes a while for gnutls-serv to start.
-          (while (and (null (ignore-errors
-                              (setq proc (open-network-stream
-                                          "bar"
-                                          (generate-new-buffer "*foo*")
-                                          "localhost"
-                                          44334
-                                          :type 'tls
-                                          :nowait nil))))
-                      (< (setq times (1+ times)) 10))
-            (sit-for 0.1))
+          (setq proc (open-network-stream
+                      "bar"
+                      (generate-new-buffer "*foo*")
+                      "localhost"
+                      port
+                      :type 'tls
+                      :nowait nil))
           (should proc)
           (skip-when (eq (process-status proc) 'connect)))
       (if (process-live-p server) (delete-process server)))
@@ -421,29 +414,22 @@
 (ert-deftest open-network-stream-tls-nowait ()
   (skip-unless (executable-find "gnutls-serv"))
   (skip-unless (gnutls-available-p))
-  (let ((server (make-tls-server 44335))
-        (times 0)
-        (network-security-level 'low)
-        proc status)
+  (let* ((s (make-tls-server))
+         (server (car s))
+         (port (cdr s))
+         (times 0)
+         (network-security-level 'low)
+         proc status)
     (unwind-protect
         (progn
-          (sleep-for 1)
-          (with-current-buffer (process-buffer server)
-            (message "gnutls-serv: %s" (buffer-string)))
-
-          ;; It takes a while for gnutls-serv to start.
-          (while (and (null (ignore-errors
-                              (setq proc (open-network-stream
-                                          "bar"
-                                          (generate-new-buffer "*foo*")
-                                          "localhost"
-                                          44335
-                                          :type 'tls
-                                          :nowait t))))
-                      (< (setq times (1+ times)) 10))
-            (sit-for 0.1))
+          (setq proc (open-network-stream
+                      "bar"
+                      (generate-new-buffer "*foo*")
+                      "localhost"
+                      port
+                      :type 'tls
+                      :nowait t))
           (should proc)
-          (setq times 0)
           (while (and (eq (process-status proc) 'connect)
                       (< (setq times (1+ times)) 10))
             (sit-for 0.1))
@@ -464,26 +450,19 @@
 (ert-deftest open-network-stream-tls ()
   (skip-unless (executable-find "gnutls-serv"))
   (skip-unless (gnutls-available-p))
-  (let ((server (make-tls-server 44336))
-        (times 0)
-        (network-security-level 'low)
-        proc status)
+  (let* ((s (make-tls-server))
+         (server (car s))
+         (port (cdr s))
+         (network-security-level 'low)
+         proc status)
     (unwind-protect
         (progn
-          (sleep-for 1)
-          (with-current-buffer (process-buffer server)
-            (message "gnutls-serv: %s" (buffer-string)))
-
-          ;; It takes a while for gnutls-serv to start.
-          (while (and (null (ignore-errors
-                              (setq proc (open-network-stream
-                                          "bar"
-                                          (generate-new-buffer "*foo*")
-                                          "localhost"
-                                          44336
-                                          :type 'tls))))
-                      (< (setq times (1+ times)) 10))
-            (sit-for 0.1))
+          (setq proc (open-network-stream
+                      "bar"
+                      (generate-new-buffer "*foo*")
+                      "localhost"
+                      port
+                      :type 'tls))
           (should proc)
           (skip-when (eq (process-status proc) 'connect)))
       (if (process-live-p server) (delete-process server)))
@@ -502,27 +481,20 @@
 (ert-deftest open-network-stream-tls-nocert ()
   (skip-unless (executable-find "gnutls-serv"))
   (skip-unless (gnutls-available-p))
-  (let ((server (make-tls-server 44337))
-        (times 0)
-        (network-security-level 'low)
-        proc status)
+  (let* ((s (make-tls-server))
+         (server (car s))
+         (port (cdr s))
+         (network-security-level 'low)
+         proc status)
     (unwind-protect
         (progn
-          (sleep-for 1)
-          (with-current-buffer (process-buffer server)
-            (message "gnutls-serv: %s" (buffer-string)))
-
-          ;; It takes a while for gnutls-serv to start.
-          (while (and (null (ignore-errors
-                              (setq proc (open-network-stream
-                                          "bar"
-                                          (generate-new-buffer "*foo*")
-                                          "localhost"
-                                          44337
-                                          :type 'tls
-                                          :client-certificate nil))))
-                      (< (setq times (1+ times)) 10))
-            (sit-for 0.1))
+          (setq proc (open-network-stream
+                      "bar"
+                      (generate-new-buffer "*foo*")
+                      "localhost"
+                      port
+                      :type 'tls
+                      :client-certificate nil))
           (should proc)
           (skip-when (eq (process-status proc) 'connect)))
       (if (process-live-p server) (delete-process server)))
@@ -541,25 +513,19 @@
 (ert-deftest open-gnutls-stream-new-api-default ()
   (skip-unless (executable-find "gnutls-serv"))
   (skip-unless (gnutls-available-p))
-  (let ((server (make-tls-server 44665))
-        (times 0)
-        proc status)
+  (let* ((s (make-tls-server))
+         (server (car s))
+         (port (cdr s))
+         proc status)
     (unwind-protect
         (progn
-          (sleep-for 1)
-          (with-current-buffer (process-buffer server)
-            (message "gnutls-serv: %s" (buffer-string)))
-
-          ;; It takes a while for gnutls-serv to start.
-          (while (and (null (ignore-errors
-                              (setq proc (open-gnutls-stream
-                                          "bar"
-                                          (generate-new-buffer "*foo*")
-                                          "localhost"
-                                          44665))))
-                      (< (setq times (1+ times)) 10))
-            (sit-for 0.1))
+          (setq proc (open-gnutls-stream
+                      "bar"
+                      (generate-new-buffer "*foo*")
+                      "localhost"
+                      port))
           (should proc)
+          (skip-when (eq (process-status proc) 'connect)))
       (if (process-live-p server) (delete-process server)))
     (setq status (gnutls-peer-status proc))
     (should (consp status))
@@ -571,31 +537,25 @@
     (let ((issuer (plist-get (plist-get status :certificate) :issuer)))
       (should (stringp issuer))
       (setq issuer (split-string issuer ","))
-      (should (equal (nth 3 issuer) "O=Emacs Test Servicess LLC"))))))
+      (should (equal (nth 3 issuer) "O=Emacs Test Servicess LLC")))))
 
 (ert-deftest open-gnutls-stream-new-api-wait ()
   (skip-unless (executable-find "gnutls-serv"))
   (skip-unless (gnutls-available-p))
-  (let ((server (make-tls-server 44666))
-        (times 0)
-        proc status)
+  (let* ((s (make-tls-server))
+         (server (car s))
+         (port (cdr s))
+         proc status)
     (unwind-protect
         (progn
-          (sleep-for 1)
-          (with-current-buffer (process-buffer server)
-            (message "gnutls-serv: %s" (buffer-string)))
-
-          ;; It takes a while for gnutls-serv to start.
-          (while (and (null (ignore-errors
-                              (setq proc (open-gnutls-stream
-                                          "bar"
-                                          (generate-new-buffer "*foo*")
-                                          "localhost"
-                                          44666
-                                          (list :nowait nil)))))
-                      (< (setq times (1+ times)) 10))
-            (sit-for 0.1))
+          (setq proc (open-gnutls-stream
+                      "bar"
+                      (generate-new-buffer "*foo*")
+                      "localhost"
+                      port
+                      (list :nowait nil)))
           (should proc)
+          (skip-when (eq (process-status proc) 'connect)))
       (if (process-live-p server) (delete-process server)))
     (setq status (gnutls-peer-status proc))
     (should (consp status))
@@ -607,32 +567,26 @@
     (let ((issuer (plist-get (plist-get status :certificate) :issuer)))
       (should (stringp issuer))
       (setq issuer (split-string issuer ","))
-      (should (equal (nth 3 issuer) "O=Emacs Test Servicess LLC"))))))
+      (should (equal (nth 3 issuer) "O=Emacs Test Servicess LLC")))))
 
 (ert-deftest open-gnutls-stream-old-api-wait ()
   (skip-unless (executable-find "gnutls-serv"))
   (skip-unless (gnutls-available-p))
-  (let ((server (make-tls-server 44667))
-        (times 0)
-        (nowait nil) ; Workaround Bug#47080
-        proc status)
+  (let* ((s (make-tls-server))
+         (server (car s))
+         (port (cdr s))
+         (nowait nil) ; Workaround Bug#47080
+         proc status)
     (unwind-protect
         (progn
-          (sleep-for 1)
-          (with-current-buffer (process-buffer server)
-            (message "gnutls-serv: %s" (buffer-string)))
-
-          ;; It takes a while for gnutls-serv to start.
-          (while (and (null (ignore-errors
-                              (setq proc (open-gnutls-stream
-                                          "bar"
-                                          (generate-new-buffer "*foo*")
-                                          "localhost"
-                                          44667
-                                          nowait))))
-                      (< (setq times (1+ times)) 10))
-            (sit-for 0.1))
+          (setq proc (open-gnutls-stream
+                      "bar"
+                      (generate-new-buffer "*foo*")
+                      "localhost"
+                      port
+                      nowait))
           (should proc)
+          (skip-when (eq (process-status proc) 'connect)))
       (if (process-live-p server) (delete-process server)))
     (setq status (gnutls-peer-status proc))
     (should (consp status))
@@ -644,33 +598,26 @@
     (let ((issuer (plist-get (plist-get status :certificate) :issuer)))
       (should (stringp issuer))
       (setq issuer (split-string issuer ","))
-      (should (equal (nth 3 issuer) "O=Emacs Test Servicess LLC"))))))
+      (should (equal (nth 3 issuer) "O=Emacs Test Servicess LLC")))))
 
 (ert-deftest open-gnutls-stream-new-api-nowait ()
   (skip-unless (executable-find "gnutls-serv"))
   (skip-unless (gnutls-available-p))
-  (let ((server (make-tls-server 44668))
-        (times 0)
-        (network-security-level 'low)
-        proc status)
+  (let* ((s (make-tls-server))
+         (server (car s))
+         (port (cdr s))
+         (times 0)
+         (network-security-level 'low)
+         proc status)
     (unwind-protect
         (progn
-          (sleep-for 1)
-          (with-current-buffer (process-buffer server)
-            (message "gnutls-serv: %s" (buffer-string)))
-
-          ;; It takes a while for gnutls-serv to start.
-          (while (and (null (ignore-errors
-                              (setq proc (open-gnutls-stream
-                                          "bar"
-                                          (generate-new-buffer "*foo*")
-                                          "localhost"
-                                          44668
-                                          (list :nowait t)))))
-                      (< (setq times (1+ times)) 10))
-            (sit-for 0.1))
+          (setq proc (open-gnutls-stream
+                      "bar"
+                      (generate-new-buffer "*foo*")
+                      "localhost"
+                      port
+                      (list :nowait t)))
           (should proc)
-          (setq times 0)
           (while (and (eq (process-status proc) 'connect)
                       (< (setq times (1+ times)) 10))
             (sit-for 0.1))
@@ -687,27 +634,21 @@
 (ert-deftest open-gnutls-stream-old-api-nowait ()
   (skip-unless (executable-find "gnutls-serv"))
   (skip-unless (gnutls-available-p))
-  (let ((server (make-tls-server 44669))
-        (times 0)
-        (network-security-level 'low)
-        (nowait t)
-        proc status)
+  (let* ((s (make-tls-server))
+         (server (car s))
+         (port (cdr s))
+         (times 0)
+         (network-security-level 'low)
+         (nowait t)
+         proc status)
     (unwind-protect
         (progn
-          (sleep-for 1)
-          (with-current-buffer (process-buffer server)
-            (message "gnutls-serv: %s" (buffer-string)))
-
-          ;; It takes a while for gnutls-serv to start.
-          (while (and (null (ignore-errors
-                              (setq proc (open-gnutls-stream
-                                          "bar"
-                                          (generate-new-buffer "*foo*")
-                                          "localhost"
-                                          44669
-                                          nowait))))
-                      (< (setq times (1+ times)) 10))
-            (sit-for 0.1))
+          (setq proc (open-gnutls-stream
+                      "bar"
+                      (generate-new-buffer "*foo*")
+                      "localhost"
+                      port
+                      nowait))
           (should proc)
           (setq times 0)
           (while (and (eq (process-status proc) 'connect)
@@ -730,14 +671,14 @@
     "bar"
     (generate-new-buffer "*foo*")
     "localhost"
-    44777
+    (+ 20000 (random 45535))
     (list t)))
   (should-error
    (open-gnutls-stream
     "bar"
     (generate-new-buffer "*foo*")
     "localhost"
-    44777
+    (+ 20000 (random 45535))
     (vector :nowait t))))
 
 (ert-deftest check-network-process-coding-system-bind ()