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                                      :family 'ipv4
 149                                      :service port)))
 150     (should (eq (process-status proc) 'connect))
 151     (while (eq (process-status proc) 'connect)
 152       (sit-for 0.1))
 153     (with-current-buffer (process-buffer proc)
 154       (process-send-string proc "echo foo")
 155       (sleep-for 0.1)
 156       (should (equal (buffer-string) "foo\n")))
 157     (delete-process server)))
 158
 159 (defun make-tls-server (port)
 160   (start-process "gnutls" (generate-new-buffer "*tls*")
 161                  "gnutls-serv" "--http"
 162                  "--x509keyfile" "data/net/key.pem"
 163                  "--x509certfile" "data/net/cert.pem"
 164                  "--port" (format "%s" port)))
 165
 166 (ert-deftest connect-to-tls-ipv4-wait ()
 167   (skip-unless (executable-find "gnutls-serv"))
 168   (skip-unless (gnutls-available-p))
 169   (let ((server (make-tls-server 44332))
 170         (times 0)
 171         proc status)
 172     (sleep-for 1)
 173     (with-current-buffer (process-buffer server)
 174       (message "gnutls-serv: %s" (buffer-string)))
 175
 176     ;; It takes a while for gnutls-serv to start.
 177     (while (and (null (ignore-errors
 178                         (setq proc (make-network-process
 179                                     :name "bar"
 180                                     :buffer (generate-new-buffer "*foo*")
 181                                     :host "localhost"
 182                                     :service 44332))))
 183                 (< (setq times (1+ times)) 10))
 184       (sit-for 0.1))
 185     (should proc)
 186     (gnutls-negotiate :process proc
 187                       :type 'gnutls-x509pki
 188                       :hostname "localhost")
 189     (delete-process server)
 190     (setq status (gnutls-peer-status proc))
 191     (should (consp status))
 192     (delete-process proc)
 193     ;; This sleep-for is needed for the native MS-Windows build.  If
 194     ;; it is removed, the next test mysteriously fails because the
 195     ;; initial part of the echo is not received.
 196     (sleep-for 0.1)
 197     (let ((issuer (plist-get (plist-get status :certificate) :issuer)))
 198       (should (stringp issuer))
 199       (setq issuer (split-string issuer ","))
 200       (should (equal (nth 3 issuer) "O=Emacs Test Servicess LLC")))))
 201
 202 (ert-deftest connect-to-tls-ipv4-nowait ()
 203   (skip-unless (executable-find "gnutls-serv"))
 204   (skip-unless (gnutls-available-p))
 205   (let ((server (make-tls-server 44331))
 206         (times 0)
 207         proc status)
 208     (sleep-for 1)
 209     (with-current-buffer (process-buffer server)
 210       (message "gnutls-serv: %s" (buffer-string)))
 211
 212     ;; It takes a while for gnutls-serv to start.
 213     (while (and (null (ignore-errors
 214                         (setq proc (make-network-process
 215                                     :name "bar"
 216                                     :buffer (generate-new-buffer "*foo*")
 217                                     :nowait t
 218                                     :tls-parameters
 219                                     (cons 'gnutls-x509pki
 220                                           (gnutls-boot-parameters
 221                                            :hostname "localhost"))
 222                                     :host "localhost"
 223                                     :service 44331))))
 224                 (< (setq times (1+ times)) 10))
 225       (sit-for 0.1))
 226     (should proc)
 227     (while (eq (process-status proc) 'connect)
 228       (sit-for 0.1))
 229     (delete-process server)
 230     (setq status (gnutls-peer-status proc))
 231     (should (consp status))
 232     (delete-process proc)
 233     (let ((issuer (plist-get (plist-get status :certificate) :issuer)))
 234       (should (stringp issuer))
 235       (setq issuer (split-string issuer ","))
 236       (should (equal (nth 3 issuer) "O=Emacs Test Servicess LLC")))))
 237
 238 (ert-deftest connect-to-tls-ipv6-nowait ()
 239   (skip-unless (executable-find "gnutls-serv"))
 240   (skip-unless (gnutls-available-p))
 241   (skip-unless (not (eq system-type 'windows-nt)))
 242   (skip-unless (featurep 'make-network-process '(:family ipv6)))
 243   (let ((server (make-tls-server 44333))
 244         (times 0)
 245         proc status)
 246     (sleep-for 1)
 247     (with-current-buffer (process-buffer server)
 248       (message "gnutls-serv: %s" (buffer-string)))
 249
 250     ;; It takes a while for gnutls-serv to start.
 251     (while (and (null (ignore-errors
 252                         (setq proc (make-network-process
 253                                     :name "bar"
 254                                     :buffer (generate-new-buffer "*foo*")
 255                                     :family 'ipv6
 256                                     :nowait t
 257                                     :tls-parameters
 258                                     (cons 'gnutls-x509pki
 259                                           (gnutls-boot-parameters
 260                                            :hostname "localhost"))
 261                                     :host "::1"
 262                                     :service 44333))))
 263                 (< (setq times (1+ times)) 10))
 264       (sit-for 0.1))
 265     (should proc)
 266     (while (eq (process-status proc) 'connect)
 267       (sit-for 0.1))
 268     (delete-process server)
 269     (setq status (gnutls-peer-status proc))
 270     (should (consp status))
 271     (delete-process proc)
 272     (let ((issuer (plist-get (plist-get status :certificate) :issuer)))
 273       (should (stringp issuer))
 274       (setq issuer (split-string issuer ","))
 275       (should (equal (nth 3 issuer) "O=Emacs Test Servicess LLC")))))
 276
 277 ;;; network-stream-tests.el ends here