code.delx.au - gnu-emacs/blob - test/lisp/net/network-stream-tests.el

   1 ;;; network-stream-tests.el --- tests for network processes       -*- lexical-binding: t; -*-
   2
   3 ;; Copyright (C) 2016 Free Software Foundation, Inc.
   4
   5 ;; Author: Lars Ingebrigtsen <larsi@gnus.org>
   6
   7 ;; This file is part of GNU Emacs.
   8
   9 ;; GNU Emacs is free software: you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation, either version 3 of the License, or
  12 ;; (at your option) any later version.
  13
  14 ;; GNU Emacs is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  21
  22 ;;; Commentary:
  23
  24
  25 ;;; Code:
  26
  27 (require 'gnutls)
  28
  29 (ert-deftest make-local-unix-server ()
  30   (skip-unless (featurep 'make-network-process '(:family local)))
  31   (let* ((file (make-temp-name "/tmp/server-test"))
  32          (server
  33           (make-network-process
  34            :name "server"
  35            :server t
  36            :buffer (get-buffer-create "*server*")
  37            :noquery t
  38            :family 'local
  39            :service file)))
  40     (should (equal (process-contact server :local) file))
  41     (delete-file (process-contact server :local))))
  42
  43 (ert-deftest make-ipv4-tcp-server-with-unspecified-port ()
  44   (let ((server
  45          (make-network-process
  46           :name "server"
  47           :server t
  48           :noquery t
  49           :family 'ipv4
  50           :service t
  51           :host 'local)))
  52     (should (and (arrayp (process-contact server :local))
  53                  (numberp (aref (process-contact server :local) 4))
  54                  (> (aref (process-contact server :local) 4) 0)))
  55     (delete-process server)))
  56
  57 (ert-deftest make-ipv4-tcp-server-with-specified-port ()
  58   (let ((server
  59          (make-network-process
  60           :name "server"
  61           :server t
  62           :noquery t
  63           :family 'ipv4
  64           :service 57869
  65           :host 'local)))
  66     (should (and (arrayp (process-contact server :local))
  67                  (= (aref (process-contact server :local) 4) 57869)))
  68     (delete-process server)))
  69
  70 (defun make-server (host)
  71   (make-network-process
  72    :name "server"
  73    :server t
  74    :noquery t
  75    :family 'ipv4
  76    :coding 'raw-text-unix
  77    :buffer (get-buffer-create "*server*")
  78    :service t
  79    :sentinel 'server-sentinel
  80    :filter 'server-process-filter
  81    :host host))
  82
  83 (defun server-sentinel (_proc _msg)
  84   )
  85
  86 (defun server-process-filter (proc string)
  87   (message "Received %s" string)
  88   (let ((prev (process-get proc 'previous-string)))
  89     (when prev
  90       (setq string (concat prev string))
  91       (process-put proc 'previous-string nil)))
  92   (if (and (not (string-match "\n" string))
  93            (> (length string) 0))
  94       (process-put proc 'previous-string string))
  95   (let ((command (split-string string)))
  96     (cond
  97      ((equal (car command) "echo")
  98       (process-send-string proc (concat (cadr command) "\n")))
  99      (t
 100       ))))
 101
 102 (ert-deftest echo-server-with-dns ()
 103   (let* ((server (make-server (system-name)))
 104          (port (aref (process-contact server :local) 4))
 105          (proc (make-network-process :name "foo"
 106                                      :buffer (generate-new-buffer "*foo*")
 107                                      :host (system-name)
 108                                      :service port)))
 109     (with-current-buffer (process-buffer proc)
 110       (process-send-string proc "echo foo")
 111       (sleep-for 0.1)
 112       (should (equal (buffer-string) "foo\n")))
 113     (delete-process server)))
 114
 115 (ert-deftest echo-server-with-localhost ()
 116   (let* ((server (make-server 'local))
 117          (port (aref (process-contact server :local) 4))
 118          (proc (make-network-process :name "foo"
 119                                      :buffer (generate-new-buffer "*foo*")
 120                                      :host "localhost"
 121                                      :service port)))
 122     (with-current-buffer (process-buffer proc)
 123       (process-send-string proc "echo foo")
 124       (sleep-for 0.1)
 125       (should (equal (buffer-string) "foo\n")))
 126     (delete-process server)))
 127
 128 (ert-deftest echo-server-with-ip ()
 129   (let* ((server (make-server 'local))
 130          (port (aref (process-contact server :local) 4))
 131          (proc (make-network-process :name "foo"
 132                                      :buffer (generate-new-buffer "*foo*")
 133                                      :host "127.0.0.1"
 134                                      :service port)))
 135     (with-current-buffer (process-buffer proc)
 136       (process-send-string proc "echo foo")
 137       (sleep-for 0.1)
 138       (should (equal (buffer-string) "foo\n")))
 139     (delete-process server)))
 140
 141 (ert-deftest echo-server-nowait ()
 142   (let* ((server (make-server 'local))
 143          (port (aref (process-contact server :local) 4))
 144          (proc (make-network-process :name "foo"
 145                                      :buffer (generate-new-buffer "*foo*")
 146                                      :host "localhost"
 147                                      :nowait t
 148                                      :service port)))
 149     (should (eq (process-status proc) 'connect))
 150     (while (eq (process-status proc) 'connect)
 151       (sit-for 0.1))
 152     (with-current-buffer (process-buffer proc)
 153       (process-send-string proc "echo foo")
 154       (sleep-for 0.1)
 155       (should (equal (buffer-string) "foo\n")))
 156     (delete-process server)))
 157
 158 (defun make-tls-server (port)
 159   (start-process "gnutls" (generate-new-buffer "*tls*")
 160                  "gnutls-serv" "--http"
 161                  "--x509keyfile" "data/net/key.pem"
 162                  "--x509certfile" "data/net/cert.pem"
 163                  "--port" (format "%s" port)))
 164
 165 (ert-deftest connect-to-tls-ipv4-wait ()
 166   (skip-unless (executable-find "gnutls-serv"))
 167   (skip-unless (gnutls-available-p))
 168   (let ((server (make-tls-server 44332))
 169         (times 0)
 170         proc status)
 171     (sleep-for 1)
 172     (with-current-buffer (process-buffer server)
 173       (message "gnutls-serv: %s" (buffer-string)))
 174
 175     ;; It takes a while for gnutls-serv to start.
 176     (while (and (null (ignore-errors
 177                         (setq proc (make-network-process
 178                                     :name "bar"
 179                                     :buffer (generate-new-buffer "*foo*")
 180                                     :host "localhost"
 181                                     :service 44332))))
 182                 (< (setq times (1+ times)) 10))
 183       (sit-for 0.1))
 184     (should proc)
 185     (gnutls-negotiate :process proc
 186                       :type 'gnutls-x509pki
 187                       :hostname "localhost")
 188     (delete-process server)
 189     (setq status (gnutls-peer-status proc))
 190     (should (consp status))
 191     (delete-process proc)
 192     ;; This sleep-for is needed for the native MS-Windows build.  If
 193     ;; it is removed, the next test mysteriously fails because the
 194     ;; initial part of the echo is not received.
 195     (sleep-for 0.1)
 196     (let ((issuer (plist-get (plist-get status :certificate) :issuer)))
 197       (should (stringp issuer))
 198       (setq issuer (split-string issuer ","))
 199       (should (equal (nth 3 issuer) "O=Emacs Test Servicess LLC")))))
 200
 201 (ert-deftest connect-to-tls-ipv4-nowait ()
 202   (skip-unless (executable-find "gnutls-serv"))
 203   (skip-unless (gnutls-available-p))
 204   (let ((server (make-tls-server 44331))
 205         (times 0)
 206         proc status)
 207     (sleep-for 1)
 208     (with-current-buffer (process-buffer server)
 209       (message "gnutls-serv: %s" (buffer-string)))
 210
 211     ;; It takes a while for gnutls-serv to start.
 212     (while (and (null (ignore-errors
 213                         (setq proc (make-network-process
 214                                     :name "bar"
 215                                     :buffer (generate-new-buffer "*foo*")
 216                                     :nowait t
 217                                     :tls-parameters
 218                                     (cons 'gnutls-x509pki
 219                                           (gnutls-boot-parameters
 220                                            :hostname "localhost"))
 221                                     :host "localhost"
 222                                     :service 44331))))
 223                 (< (setq times (1+ times)) 10))
 224       (sit-for 0.1))
 225     (should proc)
 226     (while (eq (process-status proc) 'connect)
 227       (sit-for 0.1))
 228     (delete-process server)
 229     (setq status (gnutls-peer-status proc))
 230     (should (consp status))
 231     (delete-process proc)
 232     (let ((issuer (plist-get (plist-get status :certificate) :issuer)))
 233       (should (stringp issuer))
 234       (setq issuer (split-string issuer ","))
 235       (should (equal (nth 3 issuer) "O=Emacs Test Servicess LLC")))))
 236
 237 (ert-deftest connect-to-tls-ipv6-nowait ()
 238   (skip-unless (executable-find "gnutls-serv"))
 239   (skip-unless (gnutls-available-p))
 240   (skip-unless (not (eq system-type 'windows-nt)))
 241   (skip-unless (featurep 'make-network-process '(:family ipv6)))
 242   (let ((server (make-tls-server 44333))
 243         (times 0)
 244         proc status)
 245     (sleep-for 1)
 246     (with-current-buffer (process-buffer server)
 247       (message "gnutls-serv: %s" (buffer-string)))
 248
 249     ;; It takes a while for gnutls-serv to start.
 250     (while (and (null (ignore-errors
 251                         (setq proc (make-network-process
 252                                     :name "bar"
 253                                     :buffer (generate-new-buffer "*foo*")
 254                                     :family 'ipv6
 255                                     :nowait t
 256                                     :tls-parameters
 257                                     (cons 'gnutls-x509pki
 258                                           (gnutls-boot-parameters
 259                                            :hostname "localhost"))
 260                                     :host "::1"
 261                                     :service 44333))))
 262                 (< (setq times (1+ times)) 10))
 263       (sit-for 0.1))
 264     (should proc)
 265     (while (eq (process-status proc) 'connect)
 266       (sit-for 0.1))
 267     (delete-process server)
 268     (setq status (gnutls-peer-status proc))
 269     (should (consp status))
 270     (delete-process proc)
 271     (let ((issuer (plist-get (plist-get status :certificate) :issuer)))
 272       (should (stringp issuer))
 273       (setq issuer (split-string issuer ","))
 274       (should (equal (nth 3 issuer) "O=Emacs Test Servicess LLC")))))
 275
 276 ;;; network-stream-tests.el ends here