From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.io!.POSTED.blaine.gmane.org!not-for-mail From: dick.r.chiang@gmail.com Newsgroups: gmane.emacs.bugs Subject: bug#52194: 28.0.50; [PATCH] Put paid to a flappy test module Date: Mon, 29 Nov 2021 20:38:05 -0500 Message-ID: <87pmqimnia.fsf@dick> Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" Injection-Info: ciao.gmane.io; posting-host="blaine.gmane.org:116.202.254.214"; logging-data="16044"; mail-complaints-to="usenet@ciao.gmane.io" User-Agent: Gnus/5.14 (Gnus v5.14) Commercial/28.0.50 (gnu/linux) To: 52194@debbugs.gnu.org Original-X-From: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane-mx.org@gnu.org Tue Nov 30 02:42:19 2021 Return-path: Envelope-to: geb-bug-gnu-emacs@m.gmane-mx.org Original-Received: from lists.gnu.org ([209.51.188.17]) by ciao.gmane.io with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.92) (envelope-from ) id 1mrs9z-00041F-Ge for geb-bug-gnu-emacs@m.gmane-mx.org; Tue, 30 Nov 2021 02:42:19 +0100 Original-Received: from localhost ([::1]:47266 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1mrs9y-0002wl-77 for geb-bug-gnu-emacs@m.gmane-mx.org; Mon, 29 Nov 2021 20:42:18 -0500 Original-Received: from eggs.gnu.org ([209.51.188.92]:35856) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1mrs6o-0000sH-Oz for bug-gnu-emacs@gnu.org; Mon, 29 Nov 2021 20:39:02 -0500 Original-Received: from debbugs.gnu.org ([209.51.188.43]:56565) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1mrs6o-00046c-GH for bug-gnu-emacs@gnu.org; Mon, 29 Nov 2021 20:39:02 -0500 Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1mrs6o-0008Ul-Dp for bug-gnu-emacs@gnu.org; Mon, 29 Nov 2021 20:39:02 -0500 X-Loop: help-debbugs@gnu.org Resent-From: dick.r.chiang@gmail.com Original-Sender: "Debbugs-submit" Resent-CC: bug-gnu-emacs@gnu.org Resent-Date: Tue, 30 Nov 2021 01:39:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: report 52194 X-GNU-PR-Package: emacs X-GNU-PR-Keywords: patch X-Debbugs-Original-To: bug-gnu-emacs Original-Received: via spool by submit@debbugs.gnu.org id=B.163823629632597 (code B ref -1); Tue, 30 Nov 2021 01:39:02 +0000 Original-Received: (at submit) by debbugs.gnu.org; 30 Nov 2021 01:38:16 +0000 Original-Received: from localhost ([127.0.0.1]:39878 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1mrs62-0008Te-GI for submit@debbugs.gnu.org; Mon, 29 Nov 2021 20:38:16 -0500 Original-Received: from lists.gnu.org ([209.51.188.17]:46078) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1mrs60-0008TU-0V for submit@debbugs.gnu.org; Mon, 29 Nov 2021 20:38:13 -0500 Original-Received: from eggs.gnu.org ([209.51.188.92]:35668) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1mrs5z-0000pE-Qi for bug-gnu-emacs@gnu.org; Mon, 29 Nov 2021 20:38:11 -0500 Original-Received: from [2607:f8b0:4864:20::733] (port=35732 helo=mail-qk1-x733.google.com) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1mrs5w-000416-2g for bug-gnu-emacs@gnu.org; Mon, 29 Nov 2021 20:38:11 -0500 Original-Received: by mail-qk1-x733.google.com with SMTP id m192so25086137qke.2 for ; Mon, 29 Nov 2021 17:38:07 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20210112; h=from:to:subject:date:message-id:user-agent:mime-version; bh=8hOtR1m8OSDXDa4jAp5hdI5J8AOB6lpju8TrPAaBY9s=; b=NKHr6pF9jRbkAf5p9MrUULxJOX1IerJz0t1NE4si8RQiS2n6D6gqcWAoIUE2sMPool xMYa6x2RfpuW+8kj8OnGp0egXkzmev0dU+RLeoZZ5NvaNmylUE2/bbLZWfmeqK6Y6vnH TT0b3g4zIRYmX/3zhybYJ5eg4pP3bJRXB0VyxXuihg9PQC+A/DHme9Rrm4qiU2h0+hRZ xjAB0AW1QVWpR9P0B2WA+vD3O8JOorO/k+VQ4kpdBW18NjewXOUj5ihB9iNh03dK926h 77yTXSsaFzRxLswF0xfjzV6r7/FT2XUTE+tqwuNBGYHWVvoPKuAyhrq2JXpTyESnG5Wn X3SA== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20210112; h=x-gm-message-state:from:to:subject:date:message-id:user-agent :mime-version; bh=8hOtR1m8OSDXDa4jAp5hdI5J8AOB6lpju8TrPAaBY9s=; b=nbGiNLNvxHmhX+cwkh26gnzTc2mIEcgB19kFZJOc2l9SWg+8+QBtb6ohHHFwm98vKv Kqhnoi/iEV3RI4pg9+q53k1kff+wfVH1AVXvsHAK2B1V5BVNH8aT/yR63WSpHsIVlHu7 0wMJ2Y6uRcCBGHGj929aJdwLQUc3qVaE3BRBOm1a1tks7nCF7+NkIangBqUugDGAOk9H s43tD/8xKHUuN+h6Ki+ouH1Rb9U++zAUz2J8LQvuESi90tipLCZUeGm4uQL0n/248iQn 2iu+WW4CsiZ1HXeVBnjiRQ67F1gCUZf9J/SPlmsRQRqNL9HEgpL8lhkF1vprz2WIuRIT QndA== X-Gm-Message-State: AOAM5320yvVZoe8ifUVaYn93PBLOQSkn0Z5+I9XrCtDeZnafdd2uUFmx RdyoPVasLFP7gDhcckZf+qsKlQ7qr1c= X-Google-Smtp-Source: ABdhPJx3CU2EoPSR+NkChSzBJdVp8XA8O3WWPJC+cHhxaXlPmCRqwCZHWGEN7I7P3iTpfMWp/OVMfg== X-Received: by 2002:ae9:c115:: with SMTP id z21mr33912507qki.756.1638236286316; Mon, 29 Nov 2021 17:38:06 -0800 (PST) Original-Received: from localhost ([68.237.93.126]) by smtp.gmail.com with ESMTPSA id d19sm10032440qtb.47.2021.11.29.17.38.05 (version=TLS1_2 cipher=ECDHE-ECDSA-CHACHA20-POLY1305 bits=256/256); Mon, 29 Nov 2021 17:38:05 -0800 (PST) X-Host-Lookup-Failed: Reverse DNS lookup failed for 2607:f8b0:4864:20::733 (failed) Received-SPF: pass client-ip=2607:f8b0:4864:20::733; envelope-from=dick.r.chiang@gmail.com; helo=mail-qk1-x733.google.com X-Spam_score_int: -12 X-Spam_score: -1.3 X-Spam_bar: - X-Spam_report: (-1.3 / 5.0 requ) BAYES_00=-1.9, DKIM_SIGNED=0.1, DKIM_VALID=-0.1, DKIM_VALID_AU=-0.1, DKIM_VALID_EF=-0.1, FREEMAIL_FROM=0.001, PDS_HP_HELO_NORDNS=0.001, RCVD_IN_DNSWL_NONE=-0.0001, RDNS_NONE=0.793, SPF_HELO_NONE=0.001, SPF_PASS=-0.001 autolearn=no autolearn_force=no X-Spam_action: no action X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: bug-gnu-emacs@gnu.org List-Id: "Bug reports for GNU Emacs, the Swiss army knife of text editors" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane-mx.org@gnu.org Original-Sender: "bug-gnu-emacs" Xref: news.gmane.io gmane.emacs.bugs:221094 Archived-At: --=-=-= Content-Type: text/x-diff Content-Disposition: inline; filename=0001-Don-t-repeat-yourself-DRY.patch >From 18e2cfa112c3393b4191bb3497bf9a0ae643c2a2 Mon Sep 17 00:00:00 2001 From: dickmao Date: Mon, 29 Nov 2021 20:31:28 -0500 Subject: [PATCH] Don't repeat yourself (DRY) * test/lisp/net/network-stream-tests.el (network-test--resolve-system-name): DRY. (network-stream-tests--resolve-system-name): DRY. (network-stream-tests-echo-server): DRY. (echo-server-with-dns): DRY. (echo-server-with-localhost): DRY. (echo-server-with-local-ipv4): DRY. (echo-server-with-local-ipv6): DRY. (echo-server-with-ip): DRY. (echo-server-nowait): DRY. (make-tls-server): DRY. (network-stream-tests-make-network-process): DRY. (network-stream-tests-open-stream): DRY. (network-stream-tests-doit): DRY. (connect-to-tls-ipv4-wait): DRY. (connect-to-tls-ipv4-nowait): DRY. (connect-to-tls-ipv6-nowait): DRY. (open-network-stream-tls-wait): DRY. (open-network-stream-tls-nowait): DRY. (open-network-stream-tls): DRY. (open-network-stream-tls-nocert): DRY. (open-gnutls-stream-new-api-default): DRY. (open-gnutls-stream-new-api-wait): DRY. (open-gnutls-stream-old-api-wait): DRY. (open-gnutls-stream-new-api-nowait): DRY. (open-gnutls-stream-old-api-nowait): DRY. (open-gnutls-stream-new-api-errors): DRY. --- test/lisp/net/network-stream-tests.el | 730 ++++++++------------------ 1 file changed, 206 insertions(+), 524 deletions(-) diff --git a/test/lisp/net/network-stream-tests.el b/test/lisp/net/network-stream-tests.el index 8f5bddb71f..fbb0d4af9b 100644 --- a/test/lisp/net/network-stream-tests.el +++ b/test/lisp/net/network-stream-tests.el @@ -138,7 +138,7 @@ server-process-filter (t )))) -(defun network-test--resolve-system-name () +(defun network-stream-tests--resolve-system-name () (cl-loop for address in (network-lookup-address-info (system-name)) when (or (and (= (length address) 5) ;; IPv4 localhost addresses start with 127. @@ -148,594 +148,276 @@ network-test--resolve-system-name (equal address [0 0 0 0 0 0 0 1 0]))) return t)) +(defmacro network-stream-tests-retry (&rest body) + `(cl-loop with status + repeat 30 + when (setq status (condition-case err + (progn ,@body) + (error (prog1 nil + (message "retry: %s" + (error-message-string err)))))) + return status + do (accept-process-output nil 0.3))) + +(defmacro network-stream-tests-echo-server (make-server iport &rest params) + `(let* ((server ,make-server) + (port (aref (process-contact server :local) ,iport)) + (buffer (generate-new-buffer "*foo*")) + (proc (make-network-process :name "foo" + :buffer buffer + :service port + ,@params))) + (network-stream-tests-retry (not (eq (process-status proc) 'connect))) + (unwind-protect + (with-current-buffer (process-buffer proc) + (process-send-string proc "echo foo") + (network-stream-tests-retry (equal (buffer-string) "foo\n"))) + (when (process-live-p proc) (delete-process proc)) + (let (kill-buffer-query-functions) + (kill-buffer buffer)) + (when (process-live-p server) (delete-process server))))) + (ert-deftest echo-server-with-dns () - (unless (network-test--resolve-system-name) - (ert-skip "Can't test resolver for (system-name)")) - - (let* ((server (make-server (system-name))) - (port (aref (process-contact server :local) 4)) - (proc (make-network-process :name "foo" - :buffer (generate-new-buffer "*foo*") - :host (system-name) - :service port))) - (with-current-buffer (process-buffer proc) - (process-send-string proc "echo foo") - (sleep-for 0.1) - (should (equal (buffer-string) "foo\n"))) - (delete-process server))) + (skip-unless (network-stream-tests--resolve-system-name)) + (network-stream-tests-echo-server + (make-server (system-name)) 4 + :host (system-name))) (ert-deftest echo-server-with-localhost () - (let* ((server (make-server 'local)) - (port (aref (process-contact server :local) 4)) - (proc (make-network-process :name "foo" - :buffer (generate-new-buffer "*foo*") - :host "localhost" - :service port))) - (with-current-buffer (process-buffer proc) - (process-send-string proc "echo foo") - (sleep-for 0.1) - (should (equal (buffer-string) "foo\n"))) - (delete-process server))) + (network-stream-tests-echo-server + (make-server 'local) 4 + :host "localhost")) + (ert-deftest echo-server-with-local-ipv4 () - (let* ((server (make-server 'local 'ipv4)) - (port (aref (process-contact server :local) 4)) - (proc (make-network-process :name "foo" - :buffer (generate-new-buffer "*foo*") - :host 'local - :family 'ipv4 - :service port))) - (with-current-buffer (process-buffer proc) - (process-send-string proc "echo foo") - (sleep-for 0.1) - (should (equal (buffer-string) "foo\n"))) - (delete-process server))) + (network-stream-tests-echo-server + (make-server 'local 'ipv4) 4 + :host 'local + :family 'ipv4)) (ert-deftest echo-server-with-local-ipv6 () (skip-unless (featurep 'make-network-process '(:family ipv6))) - (let ((server (ignore-errors (make-server 'local 'ipv6)))) - (skip-unless server) - (let* ((port (aref (process-contact server :local) 8)) - (proc (make-network-process :name "foo" - :buffer (generate-new-buffer "*foo*") - :host 'local - :family 'ipv6 - :service port))) - (with-current-buffer (process-buffer proc) - (process-send-string proc "echo foo") - (sleep-for 0.1) - (should (equal (buffer-string) "foo\n"))) - (delete-process server)))) + (network-stream-tests-echo-server + (make-server 'local 'ipv6) 8 + :host 'local + :family 'ipv6)) (ert-deftest echo-server-with-ip () - (let* ((server (make-server 'local)) - (port (aref (process-contact server :local) 4)) - (proc (make-network-process :name "foo" - :buffer (generate-new-buffer "*foo*") - :host "127.0.0.1" - :service port))) - (with-current-buffer (process-buffer proc) - (process-send-string proc "echo foo") - (sleep-for 0.1) - (should (equal (buffer-string) "foo\n"))) - (delete-process server))) + (network-stream-tests-echo-server + (make-server 'local) 4 + :host "127.0.0.1")) (ert-deftest echo-server-nowait () - (let* ((server (make-server 'local)) - (port (aref (process-contact server :local) 4)) - (proc (make-network-process :name "foo" - :buffer (generate-new-buffer "*foo*") - :host "localhost" - :nowait t - :family 'ipv4 - :service port)) - (times 0)) - (should (eq (process-status proc) 'connect)) - (while (and (eq (process-status proc) 'connect) - (< (setq times (1+ times)) 10)) - (sit-for 0.1)) - (skip-unless (not (eq (process-status proc) 'connect))) - (with-current-buffer (process-buffer proc) - (process-send-string proc "echo foo") - (sleep-for 0.1) - (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))) + (network-stream-tests-echo-server + (make-server 'local) 4 + :host "localhost" + :nowait t + :family 'ipv4)) + +(defun make-tls-server () + (let ((free-port (with-temp-buffer + (let ((proc (make-network-process + :name "free-port" + :noquery t + :host "127.0.0.1" + :buffer (current-buffer) + :server t + :stop t + :service t))) + (prog1 (process-contact proc :service) + (delete-process proc)))))) + (cons free-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" free-port))))) + +(defmacro network-stream-tests-make-network-process (negotiate &rest params) + `(pcase-let ((`(,port . ,server) (make-tls-server)) + (buffer (generate-new-buffer "*foo*"))) + (unwind-protect + (network-stream-tests-doit + port server + (make-network-process + :name "bar" + :buffer buffer + :service port + ,@params) + ,negotiate) + (let (kill-buffer-query-functions) + (kill-buffer buffer)) + (when (process-live-p server) (delete-process server))))) + +(defmacro network-stream-tests-open-stream (func &rest params) + `(pcase-let ((`(,port . ,server) (make-tls-server)) + (buffer (generate-new-buffer "*foo*"))) + (unwind-protect + (network-stream-tests-doit + port server + (,func + "bar" + buffer + "localhost" + port + ,@params)) + (let (kill-buffer-query-functions) + (kill-buffer buffer)) + (when (process-live-p server) (delete-process server))))) + +(cl-defmacro network-stream-tests-doit (port server form &optional negotiate) + `(let ((network-security-level 'low) + proc status) + (unwind-protect + (progn + (with-current-buffer (process-buffer ,server) + (message "gnutls-serv on %s: %s" ,port (buffer-string))) + (should (setq proc (network-stream-tests-retry ,form))) + (,(if negotiate 'funcall 'ignore) + #'gnutls-negotiate :process proc + :type 'gnutls-x509pki + :hostname "localhost") + (network-stream-tests-retry (not (eq (process-status proc) 'connect))) + (should (consp (setq status (network-stream-tests-retry + (gnutls-peer-status proc))))) + (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")))) + (when (process-live-p proc) (delete-process proc))))) (ert-deftest connect-to-tls-ipv4-wait () + :expected-result (if (getenv "CI") t :passed) (skip-unless (executable-find "gnutls-serv")) (skip-unless (gnutls-available-p)) - (let ((server (make-tls-server 44332)) - (times 0) - 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)) - (should proc) - (gnutls-negotiate :process proc - :type 'gnutls-x509pki - :hostname "localhost")) - (if (process-live-p server) (delete-process server))) - (setq status (gnutls-peer-status proc)) - (should (consp status)) - (delete-process proc) - ;; This sleep-for is needed for the native MS-Windows build. If - ;; it is removed, the next test mysteriously fails because the - ;; initial part of the echo is not received. - (sleep-for 0.1) - (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"))))) + (network-stream-tests-make-network-process + t + :host "localhost")) (ert-deftest connect-to-tls-ipv4-nowait () + :expected-result (if (getenv "CI") t :passed) (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) - (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) - (while (and (eq (process-status proc) 'connect) - (< (setq times (1+ times)) 10)) - (sit-for 0.1)) - (skip-unless (not (eq (process-status proc) 'connect)))) - (if (process-live-p server) (delete-process server))) - (setq status (gnutls-peer-status proc)) - (should (consp status)) - (delete-process proc) - (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"))))) + (network-stream-tests-make-network-process + nil + :nowait t + :family 'ipv4 + :tls-parameters + (cons 'gnutls-x509pki + (gnutls-boot-parameters + :hostname "localhost")) + :host "localhost")) (ert-deftest connect-to-tls-ipv6-nowait () + :expected-result (if (getenv "CI") t :passed) (skip-unless (executable-find "gnutls-serv")) (skip-unless (gnutls-available-p)) (skip-unless (not (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) - (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)) - (should proc) - (setq times 0) - (while (and (eq (process-status proc) 'connect) - (< (setq times (1+ times)) 10)) - (sit-for 0.1)) - (skip-unless (not (eq (process-status proc) 'connect)))) - (if (process-live-p server) (delete-process server))) - (setq status (gnutls-peer-status proc)) - (should (consp status)) - (delete-process proc) - (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"))))) + (network-stream-tests-make-network-process + nil + :family 'ipv6 + :nowait t + :tls-parameters + (cons 'gnutls-x509pki + (gnutls-boot-parameters + :hostname "localhost")) + :host "::1")) (ert-deftest open-network-stream-tls-wait () + :expected-result (if (getenv "CI") t :passed) (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) - (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)) - (should proc) - (skip-unless (not (eq (process-status proc) 'connect)))) - (if (process-live-p server) (delete-process server))) - (setq status (gnutls-peer-status proc)) - (should (consp status)) - (delete-process proc) - ;; This sleep-for is needed for the native MS-Windows build. If - ;; it is removed, the next test mysteriously fails because the - ;; initial part of the echo is not received. - (sleep-for 0.1) - (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"))))) + (network-stream-tests-open-stream + open-network-stream + :type 'tls + :nowait nil)) (ert-deftest open-network-stream-tls-nowait () + :expected-result (if (getenv "CI") t :passed) (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) - (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)) - (should proc) - (setq times 0) - (while (and (eq (process-status proc) 'connect) - (< (setq times (1+ times)) 10)) - (sit-for 0.1)) - (skip-unless (not (eq (process-status proc) 'connect)))) - (if (process-live-p server) (delete-process server))) - (setq status (gnutls-peer-status proc)) - (should (consp status)) - (delete-process proc) - ;; This sleep-for is needed for the native MS-Windows build. If - ;; it is removed, the next test mysteriously fails because the - ;; initial part of the echo is not received. - (sleep-for 0.1) - (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"))))) + (network-stream-tests-open-stream + open-network-stream + :type 'tls + :nowait t)) (ert-deftest open-network-stream-tls () + :expected-result (if (getenv "CI") t :passed) (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) - (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)) - (should proc) - (skip-unless (not (eq (process-status proc) 'connect)))) - (if (process-live-p server) (delete-process server))) - (setq status (gnutls-peer-status proc)) - (should (consp status)) - (delete-process proc) - ;; This sleep-for is needed for the native MS-Windows build. If - ;; it is removed, the next test mysteriously fails because the - ;; initial part of the echo is not received. - (sleep-for 0.1) - (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"))))) + (network-stream-tests-open-stream + open-network-stream + :type 'tls)) (ert-deftest open-network-stream-tls-nocert () + :expected-result (if (getenv "CI") t :passed) (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) - (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)) - (should proc) - (skip-unless (not (eq (process-status proc) 'connect)))) - (if (process-live-p server) (delete-process server))) - (setq status (gnutls-peer-status proc)) - (should (consp status)) - (delete-process proc) - ;; This sleep-for is needed for the native MS-Windows build. If - ;; it is removed, the next test mysteriously fails because the - ;; initial part of the echo is not received. - (sleep-for 0.1) - (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"))))) + (network-stream-tests-open-stream + open-network-stream + :type 'tls + :client-certificate nil)) (ert-deftest open-gnutls-stream-new-api-default () + :expected-result (if (getenv "CI") t :passed) (skip-unless (executable-find "gnutls-serv")) (skip-unless (gnutls-available-p)) - (let ((server (make-tls-server 44665)) - (times 0) - 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)) - (should proc) - (if (process-live-p server) (delete-process server))) - (setq status (gnutls-peer-status proc)) - (should (consp status)) - (delete-process proc) - ;; This sleep-for is needed for the native MS-Windows build. If - ;; it is removed, the next test mysteriously fails because the - ;; initial part of the echo is not received. - (sleep-for 0.1) - (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")))))) + (network-stream-tests-open-stream + open-gnutls-stream)) (ert-deftest open-gnutls-stream-new-api-wait () + :expected-result (if (getenv "CI") t :passed) (skip-unless (executable-find "gnutls-serv")) (skip-unless (gnutls-available-p)) - (let ((server (make-tls-server 44666)) - (times 0) - 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)) - (should proc) - (if (process-live-p server) (delete-process server))) - (setq status (gnutls-peer-status proc)) - (should (consp status)) - (delete-process proc) - ;; This sleep-for is needed for the native MS-Windows build. If - ;; it is removed, the next test mysteriously fails because the - ;; initial part of the echo is not received. - (sleep-for 0.1) - (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")))))) + (network-stream-tests-open-stream + open-gnutls-stream + (list :nowait nil))) (ert-deftest open-gnutls-stream-old-api-wait () + :expected-result (if (getenv "CI") t :passed) (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) - (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)) - (should proc) - (if (process-live-p server) (delete-process server))) - (setq status (gnutls-peer-status proc)) - (should (consp status)) - (delete-process proc) - ;; This sleep-for is needed for the native MS-Windows build. If - ;; it is removed, the next test mysteriously fails because the - ;; initial part of the echo is not received. - (sleep-for 0.1) - (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")))))) + (network-stream-tests-open-stream + open-gnutls-stream + nil)) (ert-deftest open-gnutls-stream-new-api-nowait () + :expected-result (if (getenv "CI") t :passed) (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) - (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)) - (should proc) - (setq times 0) - (while (and (eq (process-status proc) 'connect) - (< (setq times (1+ times)) 10)) - (sit-for 0.1)) - (skip-unless (not (eq (process-status proc) 'connect)))) - (if (process-live-p server) (delete-process server))) - (setq status (gnutls-peer-status proc)) - (should (consp status)) - (delete-process proc) - (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"))))) + (network-stream-tests-open-stream + open-gnutls-stream + (list :nowait t))) (ert-deftest open-gnutls-stream-old-api-nowait () + :expected-result (if (getenv "CI") t :passed) (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) - (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)) - (should proc) - (setq times 0) - (while (and (eq (process-status proc) 'connect) - (< (setq times (1+ times)) 10)) - (sit-for 0.1)) - (skip-unless (not (eq (process-status proc) 'connect)))) - (if (process-live-p server) (delete-process server))) - (setq status (gnutls-peer-status proc)) - (should (consp status)) - (delete-process proc) - (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"))))) + (network-stream-tests-open-stream + open-gnutls-stream + t)) (ert-deftest open-gnutls-stream-new-api-errors () (skip-unless (gnutls-available-p)) - (should-error - (open-gnutls-stream - "bar" - (generate-new-buffer "*foo*") - "localhost" - 44777 - (list t))) - (should-error - (open-gnutls-stream - "bar" - (generate-new-buffer "*foo*") - "localhost" - 44777 - (vector :nowait t)))) + (pcase-let ((`(,port . ,server) (make-tls-server))) + (kill-process server) + (should-error + (open-gnutls-stream + "bar" + (generate-new-buffer "*foo*") + "localhost" + port + (list t))) + (should-error + (open-gnutls-stream + "bar" + (generate-new-buffer "*foo*") + "localhost" + port + (vector :nowait t))))) (ert-deftest check-network-process-coding-system-bind () "Check that binding coding-system-for-{read,write} works." -- 2.26.2 --=-=-= Content-Type: text/plain In Commercial Emacs 28.0.50 (build 1, x86_64-pc-linux-gnu, GTK+ Version 3.22.30, cairo version 1.15.10) of 2021-11-28 built on dick Repository revision: ba36150bd9afe7125ca15d0031ef76e534e26fae Repository branch: longlines Windowing system distributor 'The X.Org Foundation', version 11.0.11906000 System Description: Ubuntu 18.04.4 LTS Configured using: 'configure --prefix=/home/dick/.local --with-tree-sitter --enable-dumping-overwrite --enable-profiling CC=gcc-10 'CFLAGS=-g3 -Og -I/home/dick/.local/include/' LDFLAGS=-L/home/dick/.local/lib PKG_CONFIG_PATH=/home/dick/.local/lib/pkgconfig CXX=gcc-10' Configured features: CAIRO DBUS FREETYPE GIF GLIB GMP GNUTLS GSETTINGS HARFBUZZ JPEG JSON TREE-SITTER LCMS2 LIBSELINUX LIBXML2 MODULES NOTIFY INOTIFY PDUMPER PNG RSVG SECCOMP SOUND THREADS TIFF TOOLKIT_SCROLL_BARS WEBP X11 XDBE XIM XPM GTK3 ZLIB Important settings: value of $LANG: en_US.UTF-8 locale-coding-system: utf-8-unix Major mode: Magit Minor modes in effect: async-bytecomp-package-mode: t global-git-commit-mode: t shell-dirtrack-mode: t projectile-mode: t flx-ido-mode: t override-global-mode: t global-hl-line-mode: t winner-mode: t tooltip-mode: t show-paren-mode: t mouse-wheel-mode: t file-name-shadow-mode: t global-font-lock-mode: t font-lock-mode: t blink-cursor-mode: t auto-composition-mode: t auto-encryption-mode: t auto-compression-mode: t buffer-read-only: t column-number-mode: t line-number-mode: t transient-mark-mode: t Load-path shadows: /home/dick/gomacro-mode/gomacro-mode hides /home/dick/.emacs.d/elpa/gomacro-mode-20200326.1103/gomacro-mode /home/dick/.emacs.d/elpa/hydra-20170924.2259/lv hides /home/dick/.emacs.d/elpa/lv-20191106.1238/lv /home/dick/.emacs.d/elpa/magit-3.3.0/magit-section-pkg hides /home/dick/.emacs.d/elpa/magit-section-3.3.0/magit-section-pkg /home/dick/org-gcal.el/org-gcal hides /home/dick/.emacs.d/elpa/org-gcal-0.3/org-gcal /home/dick/.emacs.d/elpa/tree-sitter-0.15.2/tree-sitter hides /home/dick/.local/share/emacs/28.0.50/lisp/tree-sitter /home/dick/.emacs.d/lisp/json hides /home/dick/.local/share/emacs/28.0.50/lisp/json /home/dick/.emacs.d/elpa/transient-0.3.6/transient hides /home/dick/.local/share/emacs/28.0.50/lisp/transient /home/dick/.emacs.d/elpa/hierarchy-20171221.1151/hierarchy hides /home/dick/.local/share/emacs/28.0.50/lisp/emacs-lisp/hierarchy Features: (shadow emacsbug git-rebase supercite regi bbdb-message sendmail footnote cus-start cl-print debug backtrace rect eieio-opt speedbar ezimage dframe shortdoc jka-compr goto-addr help-fns radix-tree find-func mule-util magit-extras face-remap magit-patch-changelog magit-patch magit-submodule magit-obsolete magit-popup async-bytecomp async magit-blame magit-stash magit-reflog magit-bisect magit-push magit-pull magit-fetch magit-clone magit-remote magit-commit magit-sequence magit-notes magit-worktree magit-tag magit-merge magit-branch magit-reset magit-files magit-refs magit-status magit magit-repos magit-apply magit-wip magit-log which-func imenu magit-diff smerge-mode diff git-commit log-edit pcvs-util add-log magit-core magit-margin magit-transient magit-process with-editor server magit-mode transient url-queue shr-color pulse ivy delsel colir ivy-overlay ffap dumb-jump f cl flow-fill qp sort smiley gnus-async gnus-ml gravatar dns mail-extr gnus-notifications gnus-fun notifications gnus-kill gnus-dup disp-table utf-7 mm-archive url-cache nnrss nnfolder nndiscourse benchmark rbenv nnhackernews nntwitter nntwitter-api bbdb-gnus gnus-demon nntp nnmairix nnml nnreddit gnus-topic url-http url-auth url-gw network-stream gnutls nsm request virtualenvwrapper gud json-rpc python tramp-sh gnus-score score-mode gnus-bcklg gnus-srvr gnus-cite anaphora bbdb-mua bbdb-com bbdb bbdb-site timezone gnus-delay gnus-draft gnus-cache gnus-agent gnus-msg gnus-art mm-uu mml2015 mm-view mml-smime smime dig gnus-sum shr kinsoku svg dom nndraft nnmh gnus-group mm-url gnus-undo use-package use-package-delight use-package-diminish gnus-start gnus-dbus gnus-cloud nnimap nnmail mail-source utf7 netrc nnoo gnus-spec gnus-int gnus-range message yank-media rmc puny rfc822 mml mml-sec epa epg rfc6068 epg-config mm-decode mm-bodies mm-encode mailabbrev gmm-utils mailheader gnus-win ag vc-svn find-dired s dired-x dired dired-loaddefs misearch multi-isearch vc-git diff-mode vc vc-dispatcher bug-reference cc-mode cc-fonts cc-guess cc-menus cc-cmds cc-styles cc-align cc-engine cc-vars cc-defs tramp-archive tramp-gvfs tramp-cache zeroconf dbus xml tramp tramp-loaddefs trampver tramp-integration files-x tramp-compat shell pcomplete parse-time iso8601 ls-lisp format-spec paredit-ext paredit subed subed-vtt subed-srt subed-common subed-mpv subed-debug subed-config inf-ruby ruby-mode smie company pcase haskell-interactive-mode haskell-presentation-mode haskell-process haskell-session haskell-compile haskell-mode haskell-cabal haskell-utils haskell-font-lock haskell-indentation haskell-string haskell-sort-imports haskell-lexeme haskell-align-imports haskell-complete-module haskell-ghc-support noutline outline flymake-proc flymake warnings etags fileloop generator xref project dabbrev haskell-customize hydra lv use-package-ensure solarized-theme solarized-definitions projectile lisp-mnt mail-parse rfc2231 ibuf-ext ibuffer ibuffer-loaddefs thingatpt magit-autorevert autorevert filenotify magit-git magit-section magit-utils crm dash rx grep compile comint ansi-color gnus nnheader gnus-util rmail rmail-loaddefs rfc2047 rfc2045 ietf-drums mm-util mail-prsvr mail-utils text-property-search time-date flx-ido flx google-translate-default-ui google-translate-core-ui facemenu color ido google-translate-core google-translate-tk google-translate-backend use-package-bind-key bind-key auto-complete easy-mmode advice edmacro kmacro popup cus-edit pp cus-load wid-edit emms-player-mplayer emms-player-simple emms emms-compat cl-extra use-package-core derived hl-line winner ring help-mode finder-inf json-reformat-autoloads json-snatcher-autoloads sml-mode-autoloads tornado-template-mode-autoloads info package browse-url url url-proxy url-privacy url-expand url-methods url-history url-cookie url-domsuf url-util mailcap url-handlers url-parse auth-source cl-seq eieio eieio-core cl-macs eieio-loaddefs password-cache json map url-vars seq gv subr-x byte-opt bytecomp byte-compile cconv cl-loaddefs cl-lib iso-transl tooltip eldoc paren electric uniquify ediff-hook vc-hooks lisp-float-type elisp-mode mwheel term/x-win x-win term/common-win x-dnd tool-bar dnd fontset image regexp-opt fringe tree-sitter tabulated-list replace newcomment text-mode lisp-mode prog-mode register page tab-bar menu-bar rfn-eshadow isearch easymenu timer select scroll-bar mouse jit-lock font-lock syntax font-core term/tty-colors frame minibuffer cl-generic cham georgian utf-8-lang misc-lang vietnamese tibetan thai tai-viet lao korean japanese eucjp-ms cp51932 hebrew greek romanian slovak czech european ethiopic indian cyrillic chinese composite emoji-zwj charscript charprop case-table epa-hook jka-cmpr-hook help simple abbrev obarray cl-preloaded nadvice button loaddefs faces cus-face macroexp files window text-properties overlay sha1 md5 base64 format env code-pages mule custom widget keymap hashtable-print-readable backquote threads dbusbind inotify lcms2 dynamic-setting system-font-setting font-render-setting cairo move-toolbar gtk x-toolkit x multi-tty make-network-process emacs) Memory information: ((conses 16 1969180 294620) (symbols 48 48794 39) (strings 32 221116 65789) (string-bytes 1 7664223) (vectors 16 109891) (vector-slots 8 2944995 231043) (floats 8 2724 5770) (intervals 56 234293 3942) (buffers 992 66)) --=-=-=--