diff options
Diffstat (limited to 'test/lisp/net/network-stream-tests.el')
| -rw-r--r-- | test/lisp/net/network-stream-tests.el | 515 |
1 files changed, 506 insertions, 9 deletions
diff --git a/test/lisp/net/network-stream-tests.el b/test/lisp/net/network-stream-tests.el index e0ecfca4a89..1bdc35da195 100644 --- a/test/lisp/net/network-stream-tests.el +++ b/test/lisp/net/network-stream-tests.el @@ -1,6 +1,6 @@ ;;; network-stream-tests.el --- tests for network processes -*- lexical-binding: t; -*- -;; Copyright (C) 2016-2017 Free Software Foundation, Inc. +;; Copyright (C) 2016-2022 Free Software Foundation, Inc. ;; Author: Lars Ingebrigtsen <larsi@gnus.org> @@ -24,7 +24,15 @@ ;;; Code: +(require 'ert) +(require 'ert-x) (require 'gnutls) +(require 'network-stream) +;; The require above is needed for 'open-network-stream' to work, but +;; it pulls in nsm, which then makes the :nowait t' tests fail unless +;; we disable the nsm, which we do by binding 'network-security-level' + +(declare-function gnutls-peer-status "gnutls.c") (ert-deftest make-local-unix-server () (skip-unless (featurep 'make-network-process '(:family local))) @@ -67,12 +75,45 @@ (= (aref (process-contact server :local) 4) 57869))) (delete-process server))) -(defun make-server (host) +(ert-deftest make-ipv6-tcp-server-with-unspecified-port () + (skip-unless (featurep 'make-network-process '(:family ipv6))) + (let ((server + (ignore-errors + (make-network-process + :name "server" + :server t + :noquery t + :family 'ipv6 + :service t + :host 'local)))) + (skip-unless server) + (should (and (arrayp (process-contact server :local)) + (numberp (aref (process-contact server :local) 8)) + (> (aref (process-contact server :local) 8) 0))) + (delete-process server))) + +(ert-deftest make-ipv6-tcp-server-with-specified-port () + (skip-unless (featurep 'make-network-process '(:family ipv6))) + (let ((server + (ignore-errors + (make-network-process + :name "server" + :server t + :noquery t + :family 'ipv6 + :service 57870 + :host 'local)))) + (skip-unless server) + (should (and (arrayp (process-contact server :local)) + (= (aref (process-contact server :local) 8) 57870))) + (delete-process server))) + +(defun make-server (host &optional family) (make-network-process :name "server" :server t :noquery t - :family 'ipv4 + :family (or family 'ipv4) :coding 'raw-text-unix :buffer (get-buffer-create "*server*") :service t @@ -89,7 +130,7 @@ (when prev (setq string (concat prev string)) (process-put proc 'previous-string nil))) - (if (and (not (string-match "\n" string)) + (if (and (not (string-search "\n" string)) (> (length string) 0)) (process-put proc 'previous-string string)) (let ((command (split-string string))) @@ -99,7 +140,20 @@ (t )))) +(defun network-test--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. + (= (elt address 0) 127)) + (and (= (length address) 9) + ;; IPv6 localhost address. + (equal address [0 0 0 0 0 0 0 1 0]))) + return t)) + (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" @@ -125,6 +179,36 @@ (should (equal (buffer-string) "foo\n"))) (delete-process server))) +(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))) + +(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)))) + (ert-deftest echo-server-with-ip () (let* ((server (make-server 'local)) (port (aref (process-contact server :local) 4)) @@ -159,16 +243,13 @@ (should (equal (buffer-string) "foo\n"))) (delete-process server))) -(defconst network-stream-tests--datadir - (expand-file-name "test/data/net" source-directory)) - (defun make-tls-server (port) (start-process "gnutls" (generate-new-buffer "*tls*") "gnutls-serv" "--http" "--x509keyfile" - (concat network-stream-tests--datadir "/key.pem") + (ert-resource-file "key.pem") "--x509certfile" - (concat network-stream-tests--datadir "/cert.pem") + (ert-resource-file "cert.pem") "--port" (format "%s" port))) (ert-deftest connect-to-tls-ipv4-wait () @@ -214,6 +295,7 @@ (skip-unless (gnutls-available-p)) (let ((server (make-tls-server 44331)) (times 0) + (network-security-level 'low) proc status) (unwind-protect (progn @@ -227,6 +309,7 @@ :name "bar" :buffer (generate-new-buffer "*foo*") :nowait t + :family 'ipv4 :tls-parameters (cons 'gnutls-x509pki (gnutls-boot-parameters @@ -257,6 +340,7 @@ (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 @@ -294,4 +378,417 @@ (setq issuer (split-string issuer ",")) (should (equal (nth 3 issuer) "O=Emacs Test Servicess LLC"))))) +(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) + (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"))))) + +(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) + (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"))))) + +(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) + (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"))))) + +(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) + (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"))))) + +(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) + (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")))))) + +(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) + (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")))))) + +(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) + (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")))))) + +(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) + (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"))))) + +(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) + (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"))))) + +(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)))) + +(ert-deftest check-network-process-coding-system-bind () + "Check that binding coding-system-for-{read,write} works." + (let* ((coding-system-for-read 'binary) + (coding-system-for-write 'utf-8-unix) + (server + (make-network-process + :name "server" + :server t + :noquery t + :family 'ipv4 + :service t + :host 'local)) + (coding (process-coding-system server))) + (should (eq (car coding) 'binary)) + (should (eq (cdr coding) 'utf-8-unix)) + (delete-process server))) + +(ert-deftest check-network-process-coding-system-no-override () + "Check that coding-system-for-{read,write} is not overridden by :coding nil." + (let* ((coding-system-for-read 'binary) + (coding-system-for-write 'utf-8-unix) + (server + (make-network-process + :name "server" + :server t + :noquery t + :family 'ipv4 + :service t + :coding nil + :host 'local)) + (coding (process-coding-system server))) + (should (eq (car coding) 'binary)) + (should (eq (cdr coding) 'utf-8-unix)) + (delete-process server))) + +(ert-deftest check-network-process-coding-system-override () + "Check that :coding non-nil overrides coding-system-for-{read,write}." + (let* ((coding-system-for-read 'binary) + (coding-system-for-write 'utf-8-unix) + (server + (make-network-process + :name "server" + :server t + :noquery t + :family 'ipv4 + :service t + :coding 'georgian-academy + :host 'local)) + (coding (process-coding-system server))) + (should (eq (car coding) 'georgian-academy)) + (should (eq (cdr coding) 'georgian-academy)) + (delete-process server))) ;;; network-stream-tests.el ends here |