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