From 0000000000000000000000000000000000000000 Mon Sep 17 00:00:00 2001 From: "F. Jason Park" Date: Thu, 13 May 2021 03:33:33 -0700 Subject: [PATCH 11/29] Add ERC test server and related resources * test/lisp/erc/erc-d/erc-d.el: Add new file providing "dumb" test server for scenarios-based testing of ERC. * test/lisp/erc/erc-d/erc-d-u.el: Add new file providing helpers for supporting for the dumb server. * test/lisp/erc/erc-d/erc-d-i.el: Add new file providing IRC protocol related helpers supporting for the dumb server. These may be relocated later once IRCv3 functionality is added. * test/lisp/erc/erc-d/erc-d-t.el: Add new file providing ERT convenience functions for use with erc-d. * test/lisp/erc/erc-d/erc-d-self.el: add new file for testing the dumb server itself. Also add related resources under the directory test/lisp/erc/erc-d/erc-d-self-resources, which mostly contains canned "dialogs" resembling I/O logs. --- test/lisp/erc/erc-d/erc-d-i.el | 127 ++ .../erc/erc-d/erc-d-self-resources/basic.eld | 32 + .../erc-d/erc-d-self-resources/depleted.eld | 12 + .../erc/erc-d/erc-d-self-resources/drop-a.eld | 4 + .../erc/erc-d/erc-d-self-resources/drop-b.eld | 4 + .../erc-d-self-resources/dynamic-barnet.eld | 33 + .../erc-d-self-resources/dynamic-foonet.eld | 32 + .../erc-d-self-resources/dynamic-stub.eld | 4 + .../erc-d/erc-d-self-resources/dynamic.eld | 30 + .../erc/erc-d/erc-d-self-resources/eof.eld | 33 + .../erc/erc-d/erc-d-self-resources/fuzzy.eld | 42 + .../erc-d-self-resources/incremental.eld | 43 + .../erc-d-self-resources/irc-parser-tests.eld | 380 +++++ .../erc-d-self-resources/linger-multi-a.eld | 3 + .../erc-d-self-resources/linger-multi-b.eld | 3 + .../erc/erc-d/erc-d-self-resources/linger.eld | 33 + .../erc-d/erc-d-self-resources/no-block.eld | 55 + .../erc-d/erc-d-self-resources/no-match.eld | 32 + .../erc-d/erc-d-self-resources/no-pong.eld | 27 + .../erc-d-self-resources/nonstandard.eld | 6 + .../erc-d-self-resources/proxy-barnet.eld | 24 + .../erc-d-self-resources/proxy-foonet.eld | 24 + .../erc-d/erc-d-self-resources/proxy-solo.eld | 9 + .../erc-d-self-resources/proxy-subprocess.el | 26 + .../erc-d/erc-d-self-resources/timeout.eld | 27 + .../erc-d/erc-d-self-resources/unexpected.eld | 28 + test/lisp/erc/erc-d/erc-d-self.el | 1307 +++++++++++++++++ test/lisp/erc/erc-d/erc-d-t.el | 169 +++ test/lisp/erc/erc-d/erc-d-u.el | 203 +++ test/lisp/erc/erc-d/erc-d.el | 996 +++++++++++++ 30 files changed, 3748 insertions(+) create mode 100644 test/lisp/erc/erc-d/erc-d-i.el create mode 100644 test/lisp/erc/erc-d/erc-d-self-resources/basic.eld create mode 100644 test/lisp/erc/erc-d/erc-d-self-resources/depleted.eld create mode 100644 test/lisp/erc/erc-d/erc-d-self-resources/drop-a.eld create mode 100644 test/lisp/erc/erc-d/erc-d-self-resources/drop-b.eld create mode 100644 test/lisp/erc/erc-d/erc-d-self-resources/dynamic-barnet.eld create mode 100644 test/lisp/erc/erc-d/erc-d-self-resources/dynamic-foonet.eld create mode 100644 test/lisp/erc/erc-d/erc-d-self-resources/dynamic-stub.eld create mode 100644 test/lisp/erc/erc-d/erc-d-self-resources/dynamic.eld create mode 100644 test/lisp/erc/erc-d/erc-d-self-resources/eof.eld create mode 100644 test/lisp/erc/erc-d/erc-d-self-resources/fuzzy.eld create mode 100644 test/lisp/erc/erc-d/erc-d-self-resources/incremental.eld create mode 100644 test/lisp/erc/erc-d/erc-d-self-resources/irc-parser-tests.eld create mode 100644 test/lisp/erc/erc-d/erc-d-self-resources/linger-multi-a.eld create mode 100644 test/lisp/erc/erc-d/erc-d-self-resources/linger-multi-b.eld create mode 100644 test/lisp/erc/erc-d/erc-d-self-resources/linger.eld create mode 100644 test/lisp/erc/erc-d/erc-d-self-resources/no-block.eld create mode 100644 test/lisp/erc/erc-d/erc-d-self-resources/no-match.eld create mode 100644 test/lisp/erc/erc-d/erc-d-self-resources/no-pong.eld create mode 100644 test/lisp/erc/erc-d/erc-d-self-resources/nonstandard.eld create mode 100644 test/lisp/erc/erc-d/erc-d-self-resources/proxy-barnet.eld create mode 100644 test/lisp/erc/erc-d/erc-d-self-resources/proxy-foonet.eld create mode 100644 test/lisp/erc/erc-d/erc-d-self-resources/proxy-solo.eld create mode 100644 test/lisp/erc/erc-d/erc-d-self-resources/proxy-subprocess.el create mode 100644 test/lisp/erc/erc-d/erc-d-self-resources/timeout.eld create mode 100644 test/lisp/erc/erc-d/erc-d-self-resources/unexpected.eld create mode 100644 test/lisp/erc/erc-d/erc-d-self.el create mode 100644 test/lisp/erc/erc-d/erc-d-t.el create mode 100644 test/lisp/erc/erc-d/erc-d-u.el create mode 100644 test/lisp/erc/erc-d/erc-d.el diff --git a/test/lisp/erc/erc-d/erc-d-i.el b/test/lisp/erc/erc-d/erc-d-i.el new file mode 100644 index 0000000000..1713c4aa8e --- /dev/null +++ b/test/lisp/erc/erc-d/erc-d-i.el @@ -0,0 +1,127 @@ +;;; erc-d-i.el --- IRC helpers for ERC test server -*- lexical-binding: t -*- + +;; Copyright (C) 2020-2021 Free Software Foundation, Inc. +;; +;; This file is part of GNU Emacs. +;; +;; This program is free software: you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see +;; . + +;;; Commentary: + +;;; Code: + +(require 'cl-lib) + +(cl-defstruct (erc-d-i-message (:conc-name erc-d-i-message.)) + "Identical to `erc-response'. +When member `compat' is nil, it means the raw message was decoded as +UTF-8 text before parsing, which is nonstandard." + (unparsed "" :type string) + (sender "" :type string) + (command "" :type string) + (command-args nil :type (list-of string)) + (contents "" :type string) + (tags nil :type (list-of (cons symbol string))) + (compat t :type boolean)) + +(defvar erc-d-i--tag-escapes + '((";" . "\\:") (" " . "\\s") ("\\" . "\\\\") ("\r" . "\\r") ("\n" . "\\n"))) + +;; XXX these are not mirror inverses; unescaping may degenerate +;; original by dropping stranded/misplaced backslashes. + +(defvar erc-d-i--tag-escaped-regexp + (rx (or ?\; ?\ ?\\ ?\r ?\n))) + +(defvar erc-d-i--tag-unescaped-regexp + (rx (or "\\:" "\\s" "\\\\" "\\r" "\\n" + (seq "\\" (or string-end (not (or ":" "n" "r" "\\"))))))) + +(defun erc-d-i--unescape-tag-value (str) + "Undo substitution of char placeholders in raw tag value STR." + (replace-regexp-in-string erc-d-i--tag-unescaped-regexp + (lambda (s) + (or (car (rassoc s erc-d-i--tag-escapes)) + (substring s 1))) + str t t)) + +(defun erc-d-i--escape-tag-value (str) + "Swap out banned chars in tag value STR with message representation." + (replace-regexp-in-string erc-d-i--tag-escaped-regexp + (lambda (s) + (cdr (assoc s erc-d-i--tag-escapes))) + str t t)) + +(defvar erc-d-i--invalid-tag-regexp (rx (any "\0\7\r\n; "))) + +;; This is `erc-v3-message-tags' with fatal errors. + +(defun erc-d-i--validate-tags (raw) + "Validate tags portion of some RAW incoming message. +RAW must not have a leading \"@\" or a trailing space. The spec says +validation shouldn't be performed on keys and that undecodeable values +or ones with illegal (unescaped) chars may be dropped. This does not +respect any of that. Its purpose is to catch bad input created by us." + (unless (> 4094 (string-bytes raw)) + ;; 417 ERR_INPUTTOOLONG Input line was too long + (error "Message tags exceed 4094 bytes: %S" raw)) + (let (tags + (tag-strings (split-string raw ";"))) + (dolist (s tag-strings (nreverse tags)) + (let* ((m (if (>= emacs-major-version 28) + (string-search "=" s) + (string-match-p "=" s))) + (key (if m (substring s 0 m) s)) + (val (when-let* (m ; check first, like (m), but shadow + (v (substring s (1+ m))) + ((not (string-equal v "")))) + (when (string-match-p erc-d-i--invalid-tag-regexp v) + (error "Bad tag: %s" s)) + (thread-first v + (decode-coding-string 'utf-8 t) + (erc-d-i--unescape-tag-value))))) + (when (string-empty-p key) + (error "Tag missing key: %S" s)) + (setf (alist-get (intern key) tags) val))))) + +(defun erc-d-i--parse-message (s &optional decode) + "Parse string S into `erc-d-i-message' object. +With DECODE, decode as UTF-8 text." + (when (string-suffix-p "\r\n" s) + (error "Unstripped message encountered")) + (when decode + (setq s (decode-coding-string s 'utf-8 t))) + (let ((mes (make-erc-d-i-message :unparsed s :compat (not decode))) + tokens) + (when-let* (((not (string-empty-p s))) + ((eq ?@ (aref s 0))) + (m (string-match " " s)) + (u (substring s 1 m))) + (setf (erc-d-i-message.tags mes) (erc-d-i--validate-tags u) + s (substring s (1+ m)))) + (if-let* ((m (string-match " :" s)) + (other-toks (split-string (substring s 0 m) " " t)) + (rest (substring s (+ 2 m)))) + (setf (erc-d-i-message.contents mes) rest + tokens (nconc other-toks (list rest))) + (setq tokens (split-string s " " t " "))) + (when (and tokens (eq ?: (aref (car tokens) 0))) + (setf (erc-d-i-message.sender mes) (substring (pop tokens) 1))) + (setf (erc-d-i-message.command mes) (or (pop tokens) "") + (erc-d-i-message.command-args mes) tokens) + mes)) + +(provide 'erc-d-i) +;;; erc-d-i.el ends here diff --git a/test/lisp/erc/erc-d/erc-d-self-resources/basic.eld b/test/lisp/erc/erc-d/erc-d-self-resources/basic.eld new file mode 100644 index 0000000000..a5f6bcb90c --- /dev/null +++ b/test/lisp/erc/erc-d/erc-d-self-resources/basic.eld @@ -0,0 +1,32 @@ +;;; -*- mode: lisp-data -*- + +((pass 10.0 "PASS " (? ?:) "changeme")) +((nick 0.2 "NICK tester")) + +((user 0.2 "USER user 0 * :tester") + (0 ":irc.example.org 001 tester :Welcome to the Internet Relay Network tester") + (0 ":irc.example.org 002 tester :Your host is irc.example.org") + (0 ":irc.example.org 003 tester :This server was created just now") + (0 ":irc.example.org 004 tester irc.example.org BERios CEIRabehiklmnoqstv Iabehkloqv") + (0 ":irc.example.org 005 tester MODES NETWORK=ExampleOrg NICKLEN=32 PREFIX=(qaohv)~&@%+" + " :are supported by this server") + (0 ":irc.example.org 251 tester :There are 3 users and 0 invisible on 1 server(s)") + ;; Just to mix thing's up (force handler to schedule timer) + (0.1 ":irc.example.org 252 tester 0 :IRC Operators online") + (0 ":irc.example.org 253 tester 0 :unregistered connections") + (0 ":irc.example.org 254 tester 1 :channels formed") + (0 ":irc.example.org 255 tester :I have 3 clients and 0 servers") + (0.1 ":irc.example.org 265 tester 3 3 :Current local users 3, max 3") + (0 ":irc.example.org 266 tester 3 3 :Current global users 3, max 3") + (0 ":irc.example.org 422 tester :MOTD File is missing")) + +((mode-user 1.2 "MODE tester +i") + (0 ":irc.example.org 221 tester +Zi") + (0 ":irc.example.org 306 tester :You have been marked as being away") + (0 ":tester!~tester@localhost JOIN #chan") + (0 ":irc.example.org 353 alice = #chan :+alice!~alice@example.com @%+bob!~bob@example.org") + (0 ":irc.example.org 366 alice #chan :End of NAMES list")) + +;; Some comment (to prevent regression) +((mode-chan 1.2 "MODE #chan") + (0.1 ":bob!~bob@example.org PRIVMSG #chan :hey")) diff --git a/test/lisp/erc/erc-d/erc-d-self-resources/depleted.eld b/test/lisp/erc/erc-d/erc-d-self-resources/depleted.eld new file mode 100644 index 0000000000..e5a7f03efb --- /dev/null +++ b/test/lisp/erc/erc-d/erc-d-self-resources/depleted.eld @@ -0,0 +1,12 @@ +;;; -*- mode: lisp-data -*- + +((pass 10.0 "PASS :changeme")) + +((~fake 3.2 "FAKE ") + (0.1 ":irc.example.org FAKE irc.example.com :ok")) + +((nick 0.2 "NICK tester")) + +((user 0.2 "USER user 0 * :tester") + (0 ":irc.example.org 001 tester :Welcome to the Internet tester") + (0 ":irc.example.org 422 tester :MOTD File is missing")) diff --git a/test/lisp/erc/erc-d/erc-d-self-resources/drop-a.eld b/test/lisp/erc/erc-d/erc-d-self-resources/drop-a.eld new file mode 100644 index 0000000000..2e23eeb20f --- /dev/null +++ b/test/lisp/erc/erc-d/erc-d-self-resources/drop-a.eld @@ -0,0 +1,4 @@ +;; -*- mode: lisp-data; -*- +((pass 1 "PASS " (? ?:) "a") + (0 "hi")) +((drop 0.01 DROP)) diff --git a/test/lisp/erc/erc-d/erc-d-self-resources/drop-b.eld b/test/lisp/erc/erc-d/erc-d-self-resources/drop-b.eld new file mode 100644 index 0000000000..facecd5e81 --- /dev/null +++ b/test/lisp/erc/erc-d/erc-d-self-resources/drop-b.eld @@ -0,0 +1,4 @@ +;; -*- mode: lisp-data; -*- +((pass 1 "PASS " (? ?:) "b") + (0 "hi")) +((linger 1 LINGER)) diff --git a/test/lisp/erc/erc-d/erc-d-self-resources/dynamic-barnet.eld b/test/lisp/erc/erc-d/erc-d-self-resources/dynamic-barnet.eld new file mode 100644 index 0000000000..36b1cc2308 --- /dev/null +++ b/test/lisp/erc/erc-d/erc-d-self-resources/dynamic-barnet.eld @@ -0,0 +1,33 @@ +;;; -*- mode: lisp-data -*- +((fake 0 "FAKE noop")) + +((nick 1.2 "NICK tester")) + +((user 2.2 "USER user 0 * :tester") + (0. ":irc.barnet.org 001 tester :Welcome to the BAR Network tester") + (0. ":irc.barnet.org 002 tester :Your host is irc.barnet.org") + (0. ":irc.barnet.org 003 tester :This server was created just now") + (0. ":irc.barnet.org 004 tester irc.barnet.org BERios CEIRabehiklmnoqstv Iabehkloqv") + (0. ":irc.barnet.org 005 tester MODES NETWORK=BarNet NICKLEN=32 PREFIX=(qaohv)~&@%+ :are supported by this server") + (0. ":irc.barnet.org 251 tester :There are 3 users and 0 invisible on 1 server(s)") + (0. ":irc.barnet.org 252 tester 0 :IRC Operators online") + (0. ":irc.barnet.org 253 tester 0 :unregistered connections") + (0. ":irc.barnet.org 254 tester 1 :channels formed") + (0. ":irc.barnet.org 255 tester :I have 3 clients and 0 servers") + (0. ":irc.barnet.org 265 tester 3 3 :Current local users 3, max 3") + (0. ":irc.barnet.org 266 tester 3 3 :Current global users 3, max 3") + (0. ":irc.barnet.org 422 tester :MOTD File is missing")) + +((mode-user 1.2 "MODE tester +i") + (0. ":irc.barnet.org 221 tester +Zi") + (0. ":irc.barnet.org 306 tester :You have been marked as being away") + (0 ":tester!~u@awyxgybtkx7uq.irc JOIN #chan") + (0 ":irc.barnet.org 353 joe = #chan :+joe!~joe@example.com @%+mike!~mike@example.org") + (0 ":irc.barnet.org 366 joe #chan :End of NAMES list")) + +((mode 1 "MODE #chan") + (0 ":irc.barnet.org 324 tester #chan +nt") + (0 ":irc.barnet.org 329 tester #chan 1620805269") + (0.1 ":joe!~u@awyxgybtkx7uq.irc PRIVMSG #chan :mike: Yes, a dozen; and as many to the vantage, as would store the world they played for.") + (0.05 ":mike!~u@awyxgybtkx7uq.irc PRIVMSG #chan :joe: As he regards his aged father's life.") + (0.05 ":joe!~u@awyxgybtkx7uq.irc PRIVMSG #chan :mike: It is a rupture that you may easily heal; and the cure of it not only saves your brother, but keeps you from dishonour in doing it.")) diff --git a/test/lisp/erc/erc-d/erc-d-self-resources/dynamic-foonet.eld b/test/lisp/erc/erc-d/erc-d-self-resources/dynamic-foonet.eld new file mode 100644 index 0000000000..e0c1e79a36 --- /dev/null +++ b/test/lisp/erc/erc-d/erc-d-self-resources/dynamic-foonet.eld @@ -0,0 +1,32 @@ +;;; -*- mode: lisp-data -*- + +((nick 1.2 "NICK tester")) + +((user 2.2 "USER user 0 * :tester") + (0. ":irc.foonet.org 001 tester :Welcome to the FOO Network tester") + (0. ":irc.foonet.org 002 tester :Your host is irc.foonet.org") + (0. ":irc.foonet.org 003 tester :This server was created just now") + (0. ":irc.foonet.org 004 tester irc.foonet.org BERios CEIRabehiklmnoqstv Iabehkloqv") + (0. ":irc.foonet.org 005 tester MODES NETWORK=FooNet NICKLEN=32 PREFIX=(qaohv)~&@%+ :are supported by this server") + (0. ":irc.foonet.org 251 tester :There are 3 users and 0 invisible on 1 server(s)") + (0. ":irc.foonet.org 252 tester 0 :IRC Operators online") + (0. ":irc.foonet.org 253 tester 0 :unregistered connections") + (0. ":irc.foonet.org 254 tester 1 :channels formed") + (0. ":irc.foonet.org 255 tester :I have 3 clients and 0 servers") + (0. ":irc.foonet.org 265 tester 3 3 :Current local users 3, max 3") + (0. ":irc.foonet.org 266 tester 3 3 :Current global users 3, max 3") + (0. ":irc.foonet.org 422 tester :MOTD File is missing")) + +((mode-user 1.2 "MODE tester +i") + (0. ":irc.foonet.org 221 tester +Zi") + (0. ":irc.foonet.org 306 tester :You have been marked as being away") + (0 ":tester!~u@awyxgybtkx7uq.irc JOIN #chan") + (0 ":irc.foonet.org 353 alice = #chan :+alice!~alice@example.com @%+bob!~bob@example.org") + (0 ":irc.foonet.org 366 alice #chan :End of NAMES list")) + +((mode 1 "MODE #chan") + (0 ":irc.foonet.org 324 tester #chan +nt") + (0 ":irc.foonet.org 329 tester #chan 1620805269") + (0.1 ":alice!~u@awyxgybtkx7uq.irc PRIVMSG #chan :bob: Yes, a dozen; and as many to the vantage, as would store the world they played for.") + (0.05 ":bob!~u@awyxgybtkx7uq.irc PRIVMSG #chan :alice: As he regards his aged father's life.") + (0.05 ":alice!~u@awyxgybtkx7uq.irc PRIVMSG #chan :bob: It is a rupture that you may easily heal; and the cure of it not only saves your brother, but keeps you from dishonour in doing it.")) diff --git a/test/lisp/erc/erc-d/erc-d-self-resources/dynamic-stub.eld b/test/lisp/erc/erc-d/erc-d-self-resources/dynamic-stub.eld new file mode 100644 index 0000000000..d93313023d --- /dev/null +++ b/test/lisp/erc/erc-d/erc-d-self-resources/dynamic-stub.eld @@ -0,0 +1,4 @@ +;;; -*- mode: lisp-data -*- +((pass 10.0 "PASS " (? ?:) token ":changeme")) + +((fake 0 "FAKE")) diff --git a/test/lisp/erc/erc-d/erc-d-self-resources/dynamic.eld b/test/lisp/erc/erc-d/erc-d-self-resources/dynamic.eld new file mode 100644 index 0000000000..8698560109 --- /dev/null +++ b/test/lisp/erc/erc-d/erc-d-self-resources/dynamic.eld @@ -0,0 +1,30 @@ +;;; -*- mode: lisp-data -*- +((pass 10.0 "PASS " (? ?:) "changeme")) +((nick 0.2 "NICK tester")) + +((user 0.2 "USER " user " " (ignored digit "*") " :" realname) + (0.0 ":" dom " 001 " nick " :Welcome to the Internet Relay Network tester") + (0.0 ":" dom " 002 " nick " :Your host is " dom) + (0.0 ":" dom " 003 " nick " :This server was created just now") + (0.0 ":" dom " 004 " nick " " dom " BERios CEIRabehiklmnoqstv Iabehkloqv") + (0.0 ":" dom " 005 " nick " MODES NETWORK=ExampleOrg NICKLEN=32 PREFIX=(qaohv)~&@%+" + " :are supported by this server") + (0.0 ":" dom " 251 " nick " :There are 3 users and 0 invisible on 1 server(s)") + (0.0 ":" dom " 252 " nick " 0 :IRC Operators online") + (0.0 ":" dom " 253 " nick " 0 :unregistered connections") + (0.0 ":" dom " 254 " nick " 1 :channels formed") + (0.0 ":" dom " 255 " nick " :I have 3 clients and 0 servers") + (0.0 ":" dom " 265 " nick " 3 3 :Current local users 3, max 3") + (0.0 ":" dom " 266 " nick " 3 3 :Current global users 3, max 3") + (0.0 ":" dom " 422 " nick " :MOTD File is missing")) + +((mode-user 1.2 "MODE tester +i") + (0.0 ":" dom " 221 " nick " +Zi") + + (0.0 ":" dom " 306 " nick " :You have been marked as being away") + (0.0 ":" nick "!~" nick "@localhost JOIN #chan") + (0.0 ":" dom " 353 alice = #chan :+alice!~alice@example.com @%+bob!~bob@example.org") + (0.0 ":" dom " 366 alice #chan :End of NAMES list")) + +((mode 1.2 "MODE #chan") + (0.1 ":bob!~bob@example.org PRIVMSG #chan :" nick ": hey")) diff --git a/test/lisp/erc/erc-d/erc-d-self-resources/eof.eld b/test/lisp/erc/erc-d/erc-d-self-resources/eof.eld new file mode 100644 index 0000000000..5da84b2e74 --- /dev/null +++ b/test/lisp/erc/erc-d/erc-d-self-resources/eof.eld @@ -0,0 +1,33 @@ +;;; -*- mode: lisp-data -*- + +((pass 10.0 "PASS " (? ?:) "changeme")) +((nick 0.2 "NICK tester")) + +((user 0.2 "USER user 0 * :tester") + (0 ":irc.example.org 001 tester :Welcome to the Internet Relay Network tester") + (0 ":irc.example.org 002 tester :Your host is irc.example.org") + (0 ":irc.example.org 003 tester :This server was created just now") + (0 ":irc.example.org 004 tester irc.example.org BERios CEIRabehiklmnoqstv Iabehkloqv") + (0 ":irc.example.org 005 tester MODES NETWORK=ExampleOrg NICKLEN=32 PREFIX=(qaohv)~&@%+" + " :are supported by this server") + (0 ":irc.example.org 251 tester :There are 3 users and 0 invisible on 1 server(s)") + ;; Just to mix thing's up (force handler to schedule timer) + (0.1 ":irc.example.org 252 tester 0 :IRC Operators online") + (0 ":irc.example.org 253 tester 0 :unregistered connections") + (0 ":irc.example.org 254 tester 1 :channels formed") + (0 ":irc.example.org 255 tester :I have 3 clients and 0 servers") + (0 ":irc.example.org 265 tester 3 3 :Current local users 3, max 3") + (0 ":irc.example.org 266 tester 3 3 :Current global users 3, max 3") + (0 ":irc.example.org 422 tester :MOTD File is missing")) + +((mode-user 1.2 "MODE tester +i") + (0 ":irc.example.org 221 tester +Zi") + (0 ":irc.example.org 306 tester :You have been marked as being away") + (0 ":tester!~tester@localhost JOIN #chan") + (0 ":irc.example.org 353 alice = #chan :+alice!~alice@example.com @%+bob!~bob@example.org") + (0 ":irc.example.org 366 alice #chan :End of NAMES list")) + +((mode-chan 1.2 "MODE #chan") + (0.1 ":bob!~bob@example.org PRIVMSG #chan :hey")) + +((eof 1.0 EOF)) diff --git a/test/lisp/erc/erc-d/erc-d-self-resources/fuzzy.eld b/test/lisp/erc/erc-d/erc-d-self-resources/fuzzy.eld new file mode 100644 index 0000000000..0504b6a668 --- /dev/null +++ b/test/lisp/erc/erc-d/erc-d-self-resources/fuzzy.eld @@ -0,0 +1,42 @@ +;;; -*- mode: lisp-data -*- +((pass 10.0 "PASS " (? ?:) "changeme")) +((nick 0.2 "NICK tester")) + +((user 0.5 "USER user 0 * :tester") + (0.0 "@time=" now " :irc.org 001 tester :Welcome to the Internet Relay Network tester") + (0.0 "@time=" now " :irc.org 002 tester :Your host is irc.org") + (0.0 "@time=" now " :irc.org 003 tester :This server was created just now") + (0.0 "@time=" now " :irc.org 004 tester irc.org BERios CEIRabehiklmnoqstv Iabehkloqv") + (0.0 "@time=" now " :irc.org 005 tester MODES NETWORK=ExampleOrg NICKLEN=32 PREFIX=(qaohv)~&@%+ :are supported by this server") + (0.0 "@time=" now " :irc.org 251 tester :There are 3 users and 0 invisible on 1 server(s)") + (0.0 "@time=" now " :irc.org 252 tester 0 :IRC Operators online") + (0.0 "@time=" now " :irc.org 253 tester 0 :unregistered connections") + (0.0 "@time=" now " :irc.org 254 tester 1 :channels formed") + (0.0 "@time=" now " :irc.org 255 tester :I have 3 clients and 0 servers") + (0.0 "@time=" now " :irc.org 265 tester 3 3 :Current local users 3, max 3") + (0.0 "@time=" now " :irc.org 266 tester 3 3 :Current global users 3, max 3") + (0.0 "@time=" now " :irc.org 422 tester :MOTD File is missing")) + +((mode-user 1.2 "MODE tester +i") + (0.0 "@time=" now " :irc.org 221 tester +Zi") + (0.0 "@time=" now " :irc.org 306 tester :You have been marked as being away")) + +((~join-foo 3.2 "JOIN #foo") + (0 "@time=" now " :tester!~tester@localhost JOIN #foo") + (0 "@time=" now " :irc.example.org 353 alice = #foo :+alice!~alice@example.com @%+bob!~bob@example.org") + (0 "@time=" now " :irc.example.org 366 alice #foo :End of NAMES list")) + +((~join-bar 1.2 "JOIN #bar") + (0 "@time=" now " :tester!~tester@localhost JOIN #bar") + (0 "@time=" now " :irc.example.org 353 alice = #bar :+alice!~alice@example.com @%+bob!~bob@example.org") + (0 "@time=" now " :irc.example.org 366 alice #bar :End of NAMES list")) + +((~mode-foo 3.2 "MODE #foo") + (0.0 "@time=" now " :irc.example.org 324 tester #foo +Cint") + (0.0 "@time=" now " :irc.example.org 329 tester #foo 1519850102") + (0.1 "@time=" now " :bob!~bob@example.org PRIVMSG #foo :hey")) + +((mode-bar 10.2 "MODE #bar") + (0.0 "@time=" now " :irc.example.org 324 tester #bar +HMfnrt 50:5h :10:5") + (0.0 "@time=" now " :irc.example.org 329 tester #bar :1602642829") + (0.1 "@time=" now " :alice!~alice@example.com PRIVMSG #bar :hi")) diff --git a/test/lisp/erc/erc-d/erc-d-self-resources/incremental.eld b/test/lisp/erc/erc-d/erc-d-self-resources/incremental.eld new file mode 100644 index 0000000000..ab940fe612 --- /dev/null +++ b/test/lisp/erc/erc-d/erc-d-self-resources/incremental.eld @@ -0,0 +1,43 @@ +;;; -*- mode: lisp-data -*- +((pass 10.0 "PASS " (? ?:) "changeme")) +((nick 0.2 "NICK tester")) + +((user 0.2 "USER user 0 * :tester") + (0.0 ":irc.foo.net 001 tester :Welcome to the Internet Relay Network tester") + (0.0 ":irc.foo.net 002 tester :Your host is irc.foo.net") + (0.0 ":irc.foo.net 003 tester :This server was created just now") + (0.0 ":irc.foo.net 004 tester irc.foo.net BERios CEIRabehiklmnoqstv Iabehkloqv") + (0.0 ":irc.foo.net 005 tester MODES NETWORK=FooNet NICKLEN=32 PREFIX=(qaohv)~&@%+" + " :are supported by this server") + (0.0 ":irc.foo.net 251 tester :There are 3 users and 0 invisible on 1 server(s)") + (0.0 ":irc.foo.net 252 tester 0 :IRC Operators online") + (0.0 ":irc.foo.net 253 tester 0 :unregistered connections") + (0.0 ":irc.foo.net 254 tester 1 :channels formed") + (0.0 ":irc.foo.net 255 tester :I have 3 clients and 0 servers") + (0.0 ":irc.foo.net 265 tester 3 3 :Current local users 3, max 3") + (0.0 ":irc.foo.net 266 tester 3 3 :Current global users 3, max 3") + (0.0 ":irc.foo.net 422 tester :MOTD File is missing")) + +((mode-user 1.2 "MODE tester +i") + (0.0 ":irc.foo.net 221 tester +Zi") + (0.0 ":irc.foo.net 306 tester :You have been marked as being away")) + +((join 3 "JOIN #foo") + (0 ":tester!~tester@localhost JOIN #foo") + (0 ":irc.foo.net 353 alice = #foo :+alice!~alice@example.com @%+bob!~bob@example.org") + (0 ":irc.foo.net 366 alice #foo :End of NAMES list")) + +((mode 3 "MODE #foo") + (0.0 ":irc.foo.net 324 tester #foo +Cint") + (0.0 ":irc.foo.net 329 tester #foo 1519850102") + (0.1 ":bob!~u@svpn88yjcdj42.irc PRIVMSG #foo :alice: But, in defence, by mercy, 'tis most just.") + (0.1 ":alice!~u@svpn88yjcdj42.irc PRIVMSG #foo :bob: Grows, lives, and dies, in single blessedness.") + (0.1 ":bob!~u@svpn88yjcdj42.irc PRIVMSG #foo :Look for me.") + (0.1 ":alice!~u@svpn88yjcdj42.irc PRIVMSG #foo :bob: By this hand, it will not kill a fly. But come, now I will be your Rosalind in a more coming-on disposition; and ask me what you will, I will grant it.") + (0.1 ":bob!~u@svpn88yjcdj42.irc PRIVMSG #foo :alice: That I must love a loathed enemy.") + (0.1 ":alice!~u@svpn88yjcdj42.irc PRIVMSG #foo :bob: As't please your lordship: I'll leave you.") + (0.1 ":bob!~u@svpn88yjcdj42.irc PRIVMSG #foo :alice: Then there is no true lover in the forest; else sighing every minute and groaning every hour would detect the lazy foot of Time as well as a clock.") + (0.1 ":alice!~u@svpn88yjcdj42.irc PRIVMSG #foo :bob: His discretion, I am sure, cannot carry his valour, for the goose carries not the fox. It is well: leave it to his discretion, and let us listen to the moon.") + (0.1 ":bob!~u@svpn88yjcdj42.irc PRIVMSG #foo :Done")) + +((hi 10 "PRIVMSG #foo :Hi")) diff --git a/test/lisp/erc/erc-d/erc-d-self-resources/irc-parser-tests.eld b/test/lisp/erc/erc-d/erc-d-self-resources/irc-parser-tests.eld new file mode 100644 index 0000000000..168569f548 --- /dev/null +++ b/test/lisp/erc/erc-d/erc-d-self-resources/irc-parser-tests.eld @@ -0,0 +1,380 @@ +;;; -*- mode: lisp-data; -*- + +;; https://github.com/DanielOaks/irc-parser-tests +((mask-match + (tests + ((mask . "*@127.0.0.1") + (matches "coolguy!ab@127.0.0.1" "cooldud3!~bc@127.0.0.1") + (fails "coolguy!ab@127.0.0.5" "cooldud3!~d@124.0.0.1")) + ((mask . "cool*@*") + (matches "coolguy!ab@127.0.0.1" "cooldud3!~bc@127.0.0.1" "cool132!ab@example.com") + (fails "koolguy!ab@127.0.0.5" "cooodud3!~d@124.0.0.1")) + ((mask . "cool!*@*") + (matches "cool!guyab@127.0.0.1" "cool!~dudebc@127.0.0.1" "cool!312ab@example.com") + (fails "coolguy!ab@127.0.0.1" "cooldud3!~bc@127.0.0.1" "koolguy!ab@127.0.0.5" "cooodud3!~d@124.0.0.1")) + ((mask . "cool!?username@*") + (matches "cool!ausername@127.0.0.1" "cool!~username@127.0.0.1") + (fails "cool!username@127.0.0.1")) + ((mask . "cool!a?*@*") + (matches "cool!ab@127.0.0.1" "cool!abc@127.0.0.1") + (fails "cool!a@127.0.0.1")) + ((mask . "cool[guy]!*@*") + (matches "cool[guy]!guy@127.0.0.1" "cool[guy]!a@example.com") + (fails "coolg!ab@127.0.0.1" "cool[!ac@127.0.1.1")))) + (msg-join + (tests + ((desc . "Simple test with verb and params.") + (atoms + (verb . "foo") + (params "bar" "baz" "asdf")) + (matches "foo bar baz asdf" "foo bar baz :asdf")) + ((desc . "Simple test with source and no params.") + (atoms + (source . "src") + (verb . "AWAY")) + (matches ":src AWAY")) + ((desc . "Simple test with source and empty trailing param.") + (atoms + (source . "src") + (verb . "AWAY") + (params "")) + (matches ":src AWAY :")) + ((desc . "Simple test with source.") + (atoms + (source . "coolguy") + (verb . "foo") + (params "bar" "baz" "asdf")) + (matches ":coolguy foo bar baz asdf" ":coolguy foo bar baz :asdf")) + ((desc . "Simple test with trailing param.") + (atoms + (verb . "foo") + (params "bar" "baz" "asdf quux")) + (matches "foo bar baz :asdf quux")) + ((desc . "Simple test with empty trailing param.") + (atoms + (verb . "foo") + (params "bar" "baz" "")) + (matches "foo bar baz :")) + ((desc . "Simple test with trailing param containing colon.") + (atoms + (verb . "foo") + (params "bar" "baz" ":asdf")) + (matches "foo bar baz ::asdf")) + ((desc . "Test with source and trailing param.") + (atoms + (source . "coolguy") + (verb . "foo") + (params "bar" "baz" "asdf quux")) + (matches ":coolguy foo bar baz :asdf quux")) + ((desc . "Test with trailing containing beginning+end whitespace.") + (atoms + (source . "coolguy") + (verb . "foo") + (params "bar" "baz" " asdf quux ")) + (matches ":coolguy foo bar baz : asdf quux ")) + ((desc . "Test with trailing containing what looks like another trailing param.") + (atoms + (source . "coolguy") + (verb . "PRIVMSG") + (params "bar" "lol :) ")) + (matches ":coolguy PRIVMSG bar :lol :) ")) + ((desc . "Simple test with source and empty trailing.") + (atoms + (source . "coolguy") + (verb . "foo") + (params "bar" "baz" "")) + (matches ":coolguy foo bar baz :")) + ((desc . "Trailing contains only spaces.") + (atoms + (source . "coolguy") + (verb . "foo") + (params "bar" "baz" " ")) + (matches ":coolguy foo bar baz : ")) + ((desc . "Param containing tab (tab is not considered SPACE for message splitting).") + (atoms + (source . "coolguy") + (verb . "foo") + (params "b ar" "baz")) + (matches ":coolguy foo b ar baz" ":coolguy foo b ar :baz")) + ((desc . "Tag with no value and space-filled trailing.") + (atoms + (tags + (asd . "")) + (source . "coolguy") + (verb . "foo") + (params "bar" "baz" " ")) + (matches "@asd :coolguy foo bar baz : ")) + ((desc . "Tags with escaped values.") + (atoms + (verb . "foo") + (tags + (a . "b\\and\nk") + (d . "gh;764"))) + (matches "@a=b\\\\and\\nk;d=gh\\:764 foo" "@d=gh\\:764;a=b\\\\and\\nk foo")) + ((desc . "Tags with escaped values and params.") + (atoms + (verb . "foo") + (tags + (a . "b\\and\nk") + (d . "gh;764")) + (params "par1" "par2")) + (matches "@a=b\\\\and\\nk;d=gh\\:764 foo par1 par2" "@a=b\\\\and\\nk;d=gh\\:764 foo par1 :par2" "@d=gh\\:764;a=b\\\\and\\nk foo par1 par2" "@d=gh\\:764;a=b\\\\and\\nk foo par1 :par2")) + ((desc . "Tag with long, strange values (including LF and newline).") + (atoms + (tags + (foo . "\\\\;\\s \n")) + (verb . "COMMAND")) + (matches "@foo=\\\\\\\\\\:\\\\s\\s\\r\\n COMMAND")))) + (msg-split + (tests + ((input . "foo bar baz asdf") + (atoms + (verb . "foo") + (params "bar" "baz" "asdf"))) + ((input . ":coolguy foo bar baz asdf") + (atoms + (source . "coolguy") + (verb . "foo") + (params "bar" "baz" "asdf"))) + ((input . "foo bar baz :asdf quux") + (atoms + (verb . "foo") + (params "bar" "baz" "asdf quux"))) + ((input . "foo bar baz :") + (atoms + (verb . "foo") + (params "bar" "baz" ""))) + ((input . "foo bar baz ::asdf") + (atoms + (verb . "foo") + (params "bar" "baz" ":asdf"))) + ((input . ":coolguy foo bar baz :asdf quux") + (atoms + (source . "coolguy") + (verb . "foo") + (params "bar" "baz" "asdf quux"))) + ((input . ":coolguy foo bar baz : asdf quux ") + (atoms + (source . "coolguy") + (verb . "foo") + (params "bar" "baz" " asdf quux "))) + ((input . ":coolguy PRIVMSG bar :lol :) ") + (atoms + (source . "coolguy") + (verb . "PRIVMSG") + (params "bar" "lol :) "))) + ((input . ":coolguy foo bar baz :") + (atoms + (source . "coolguy") + (verb . "foo") + (params "bar" "baz" ""))) + ((input . ":coolguy foo bar baz : ") + (atoms + (source . "coolguy") + (verb . "foo") + (params "bar" "baz" " "))) + ((input . "@a=b;c=32;k;rt=ql7 foo") + (atoms + (verb . "foo") + (tags + (a . "b") + (c . "32") + (k . "") + (rt . "ql7")))) + ((input . "@a=b\\\\and\\nk;c=72\\s45;d=gh\\:764 foo") + (atoms + (verb . "foo") + (tags + (a . "b\\and\nk") + (c . "72 45") + (d . "gh;764")))) + ((input . "@c;h=;a=b :quux ab cd") + (atoms + (tags + (c . "") + (h . "") + (a . "b")) + (source . "quux") + (verb . "ab") + (params "cd"))) + ((input . ":src JOIN #chan") + (atoms + (source . "src") + (verb . "JOIN") + (params "#chan"))) + ((input . ":src JOIN :#chan") + (atoms + (source . "src") + (verb . "JOIN") + (params "#chan"))) + ((input . ":src AWAY") + (atoms + (source . "src") + (verb . "AWAY"))) + ((input . ":src AWAY ") + (atoms + (source . "src") + (verb . "AWAY"))) + ((input . ":cool guy foo bar baz") + (atoms + (source . "cool guy") + (verb . "foo") + (params "bar" "baz"))) + ((input . ":coolguy!ag@net5work.admin PRIVMSG foo :bar baz") + (atoms + (source . "coolguy!ag@net5work.admin") + (verb . "PRIVMSG") + (params "foo" "bar baz"))) + ((input . ":coolguy!~ag@net05work.admin PRIVMSG foo :bar baz") + (atoms + (source . "coolguy!~ag@net05work.admin") + (verb . "PRIVMSG") + (params "foo" "bar baz"))) + ((input . "@tag1=value1;tag2;vendor1/tag3=value2;vendor2/tag4= :irc.example.com COMMAND param1 param2 :param3 param3") + (atoms + (tags + (tag1 . "value1") + (tag2 . "") + (vendor1/tag3 . "value2") + (vendor2/tag4 . "")) + (source . "irc.example.com") + (verb . "COMMAND") + (params "param1" "param2" "param3 param3"))) + ((input . ":irc.example.com COMMAND param1 param2 :param3 param3") + (atoms + (source . "irc.example.com") + (verb . "COMMAND") + (params "param1" "param2" "param3 param3"))) + ((input . "@tag1=value1;tag2;vendor1/tag3=value2;vendor2/tag4 COMMAND param1 param2 :param3 param3") + (atoms + (tags + (tag1 . "value1") + (tag2 . "") + (vendor1/tag3 . "value2") + (vendor2/tag4 . "")) + (verb . "COMMAND") + (params "param1" "param2" "param3 param3"))) + ((input . "COMMAND") + (atoms + (verb . "COMMAND"))) + ((input . "@foo=\\\\\\\\\\:\\\\s\\s\\r\\n COMMAND") + (atoms + (tags + (foo . "\\\\;\\s \n")) + (verb . "COMMAND"))) + ((input . ":gravel.mozilla.org 432 #momo :Erroneous Nickname: Illegal characters") + (atoms + (source . "gravel.mozilla.org") + (verb . "432") + (params "#momo" "Erroneous Nickname: Illegal characters"))) + ((input . ":gravel.mozilla.org MODE #tckk +n ") + (atoms + (source . "gravel.mozilla.org") + (verb . "MODE") + (params "#tckk" "+n"))) + ((input . ":services.esper.net MODE #foo-bar +o foobar ") + (atoms + (source . "services.esper.net") + (verb . "MODE") + (params "#foo-bar" "+o" "foobar"))) + ((input . "@tag1=value\\\\ntest COMMAND") + (atoms + (tags + (tag1 . "value\\ntest")) + (verb . "COMMAND"))) + ((input . "@tag1=value\\1 COMMAND") + (atoms + (tags + (tag1 . "value1")) + (verb . "COMMAND"))) + ((input . "@tag1=value1\\ COMMAND") + (atoms + (tags + (tag1 . "value1")) + (verb . "COMMAND"))) + ((input . "@tag1=1;tag2=3;tag3=4;tag1=5 COMMAND") + (atoms + (tags + (tag1 . "5") + (tag2 . "3") + (tag3 . "4")) + (verb . "COMMAND"))) + ((input . "@tag1=1;tag2=3;tag3=4;tag1=5;vendor/tag2=8 COMMAND") + (atoms + (tags + (tag1 . "5") + (tag2 . "3") + (tag3 . "4") + (vendor/tag2 . "8")) + (verb . "COMMAND"))) + ((input . ":SomeOp MODE #channel :+i") + (atoms + (source . "SomeOp") + (verb . "MODE") + (params "#channel" "+i"))) + ((input . ":SomeOp MODE #channel +oo SomeUser :AnotherUser") + (atoms + (source . "SomeOp") + (verb . "MODE") + (params "#channel" "+oo" "SomeUser" "AnotherUser"))))) + (userhost-split + (tests + ((source . "coolguy") + (atoms + (nick . "coolguy"))) + ((source . "coolguy!ag@127.0.0.1") + (atoms + (nick . "coolguy") + (user . "ag") + (host . "127.0.0.1"))) + ((source . "coolguy!~ag@localhost") + (atoms + (nick . "coolguy") + (user . "~ag") + (host . "localhost"))) + ((source . "coolguy@127.0.0.1") + (atoms + (nick . "coolguy") + (host . "127.0.0.1"))) + ((source . "coolguy!ag") + (atoms + (nick . "coolguy") + (user . "ag"))) + ((source . "coolguy!ag@net5work.admin") + (atoms + (nick . "coolguy") + (user . "ag") + (host . "net5work.admin"))) + ((source . "coolguy!~ag@net05work.admin") + (atoms + (nick . "coolguy") + (user . "~ag") + (host . "net05work.admin"))))) + (validate-hostname + (tests + ((host . "irc.example.com") + (valid . t)) + ((host . "i.coolguy.net") + (valid . t)) + ((host . "irc-srv.net.uk") + (valid . t)) + ((host . "iRC.CooLguY.NeT") + (valid . t)) + ((host . "gsf.ds342.co.uk") + (valid . t)) + ((host . "324.net.uk") + (valid . t)) + ((host . "xn--bcher-kva.ch") + (valid . t)) + ((host . "-lol-.net.uk") + (valid . :false)) + ((host . "-lol.net.uk") + (valid . :false)) + ((host . "_irc._sctp.lol.net.uk") + (valid . :false)) + ((host . "irc") + (valid . :false)) + ((host . "com") + (valid . :false)) + ((host . "") + (valid . :false))))) diff --git a/test/lisp/erc/erc-d/erc-d-self-resources/linger-multi-a.eld b/test/lisp/erc/erc-d/erc-d-self-resources/linger-multi-a.eld new file mode 100644 index 0000000000..751500537d --- /dev/null +++ b/test/lisp/erc/erc-d/erc-d-self-resources/linger-multi-a.eld @@ -0,0 +1,3 @@ +;; -*- mode: lisp-data; -*- +((pass 1 "PASS " (? ?:) "a")) +((linger 100 LINGER)) \ No newline at end of file diff --git a/test/lisp/erc/erc-d/erc-d-self-resources/linger-multi-b.eld b/test/lisp/erc/erc-d/erc-d-self-resources/linger-multi-b.eld new file mode 100644 index 0000000000..c906c9e649 --- /dev/null +++ b/test/lisp/erc/erc-d/erc-d-self-resources/linger-multi-b.eld @@ -0,0 +1,3 @@ +;; -*- mode: lisp-data; -*- +((pass 1 "PASS " (? ?:) "b")) +((linger 1 LINGER)) diff --git a/test/lisp/erc/erc-d/erc-d-self-resources/linger.eld b/test/lisp/erc/erc-d/erc-d-self-resources/linger.eld new file mode 100644 index 0000000000..36c81a3af4 --- /dev/null +++ b/test/lisp/erc/erc-d/erc-d-self-resources/linger.eld @@ -0,0 +1,33 @@ +;;; -*- mode: lisp-data -*- + +((pass 10.0 "PASS " (? ?:) "changeme")) +((nick 0.2 "NICK tester")) + +((user 0.2 "USER user 0 * :tester") + (0 ":irc.example.org 001 tester :Welcome to the Internet Relay Network tester") + (0 ":irc.example.org 002 tester :Your host is irc.example.org") + (0 ":irc.example.org 003 tester :This server was created just now") + (0 ":irc.example.org 004 tester irc.example.org BERios CEIRabehiklmnoqstv Iabehkloqv") + (0 ":irc.example.org 005 tester MODES NETWORK=ExampleOrg NICKLEN=32 PREFIX=(qaohv)~&@%+" + " :are supported by this server") + (0 ":irc.example.org 251 tester :There are 3 users and 0 invisible on 1 server(s)") + ;; Just to mix thing's up (force handler to schedule timer) + (0.1 ":irc.example.org 252 tester 0 :IRC Operators online") + (0 ":irc.example.org 253 tester 0 :unregistered connections") + (0 ":irc.example.org 254 tester 1 :channels formed") + (0 ":irc.example.org 255 tester :I have 3 clients and 0 servers") + (0 ":irc.example.org 265 tester 3 3 :Current local users 3, max 3") + (0 ":irc.example.org 266 tester 3 3 :Current global users 3, max 3") + (0 ":irc.example.org 422 tester :MOTD File is missing")) + +((mode-user 1.2 "MODE tester +i") + (0 ":irc.example.org 221 tester +Zi") + (0 ":irc.example.org 306 tester :You have been marked as being away") + (0 ":tester!~tester@localhost JOIN #chan") + (0 ":irc.example.org 353 alice = #chan :+alice!~alice@example.com @%+bob!~bob@example.org") + (0 ":irc.example.org 366 alice #chan :End of NAMES list")) + +((mode-chan 1.2 "MODE #chan") + (0 ":bob!~bob@example.org PRIVMSG #chan :hey")) + +((linger 1.0 LINGER)) diff --git a/test/lisp/erc/erc-d/erc-d-self-resources/no-block.eld b/test/lisp/erc/erc-d/erc-d-self-resources/no-block.eld new file mode 100644 index 0000000000..cd341dd192 --- /dev/null +++ b/test/lisp/erc/erc-d/erc-d-self-resources/no-block.eld @@ -0,0 +1,55 @@ +;;; -*- mode: lisp-data -*- +((pass 10.0 "PASS " (? ?:) "changeme")) +((nick 0.2 "NICK tester")) + +((user 0.2 "USER user 0 * :tester") + (0.0 ":irc.org 001 tester :Welcome to the Internet Relay Network tester") + (0.0 ":irc.org 002 tester :Your host is irc.org") + (0.0 ":irc.org 003 tester :This server was created just now") + (0.0 ":irc.org 004 tester irc.org BERios CEIRabehiklmnoqstv Iabehkloqv") + (0.0 ":irc.org 005 tester MODES NETWORK=ExampleOrg NICKLEN=32 PREFIX=(qaohv)~&@%+" + " :are supported by this server") + (0.0 ":irc.org 251 tester :There are 3 users and 0 invisible on 1 server(s)") + (0.0 ":irc.org 252 tester 0 :IRC Operators online") + (0.0 ":irc.org 253 tester 0 :unregistered connections") + (0.0 ":irc.org 254 tester 1 :channels formed") + (0.0 ":irc.org 255 tester :I have 3 clients and 0 servers") + (0.0 ":irc.org 265 tester 3 3 :Current local users 3, max 3") + (0.0 ":irc.org 266 tester 3 3 :Current global users 3, max 3") + (0.0 ":irc.org 422 tester :MOTD File is missing")) + +((mode-user 1.2 "MODE tester +i") + (0.0 ":irc.org 221 tester +Zi") + (0.0 ":irc.org 306 tester :You have been marked as being away")) + +((join-foo 1.2 "JOIN #foo") + (0 ":tester!~tester@localhost JOIN #foo") + (0 ":irc.example.org 353 alice = #foo :+alice!~alice@example.com @%+bob!~bob@example.org") + (0 ":irc.example.org 366 alice #foo :End of NAMES list")) + +;; This would time out if the mode-foo's outgoing blocked (remove minus signs to see) +((~join-bar 1.5 "JOIN #bar") + (0 ":tester!~tester@localhost JOIN #bar") + (0 ":irc.example.org 353 alice = #bar :+alice!~alice@example.com @%+bob!~bob@example.org") + (0 ":irc.example.org 366 alice #bar :End of NAMES list")) + +((mode-foo 1.2 "MODE #foo") + (0.0 ":irc.example.org 324 tester #foo +Cint") + (0.0 ":irc.example.org 329 tester #foo 1519850102") + (-0.1 ":bob!~u@svpn88yjcdj42.irc PRIVMSG #foo :alice: But, in defence, by mercy, 'tis most just.") + (-0.2 ":alice!~u@svpn88yjcdj42.irc PRIVMSG #foo :bob: Grows, lives, and dies, in single blessedness.") + (-0.3 ":bob!~u@svpn88yjcdj42.irc PRIVMSG #foo :alice: For these two hours, Rosalind, I will leave thee.") + (-0.4 ":alice!~u@svpn88yjcdj42.irc PRIVMSG #foo :bob: By this hand, it will not kill a fly. But come, now I will be your Rosalind in a more coming-on disposition; and ask me what you will, I will grant it.") + (-0.5 ":bob!~u@svpn88yjcdj42.irc PRIVMSG #foo :alice: That I must love a loathed enemy.") + (-0.6 ":alice!~u@svpn88yjcdj42.irc PRIVMSG #foo :bob: As't please your lordship: I'll leave you.") + (-0.7 ":bob!~u@svpn88yjcdj42.irc PRIVMSG #foo :alice: Then there is no true lover in the forest; else sighing every minute and groaning every hour would detect the lazy foot of Time as well as a clock.") + (-0.8 ":alice!~u@svpn88yjcdj42.irc PRIVMSG #foo :bob: His discretion, I am sure, cannot carry his valour, for the goose carries not the fox. It is well: leave it to his discretion, and let us listen to the moon.") + (-0.9 ":bob!~u@svpn88yjcdj42.irc PRIVMSG #foo :alice: As living here and you no use of him.") + (-1.0 ":alice!~u@svpn88yjcdj42.irc PRIVMSG #foo :bob: If there be truth in sight, you are my Rosalind.") + (-1.1 ":bob!~u@svpn88yjcdj42.irc PRIVMSG #foo :alice: That is another's lawful promis'd love.") + (-1.1 ":bob!~u@svpn88yjcdj42.irc PRIVMSG #foo :I am heard.")) + +((mode-bar 1.5 "MODE #bar") + (0.0 ":irc.example.org 324 tester #bar +HMfnrt 50:5h :10:5") + (0.0 ":irc.example.org 329 tester #bar :1602642829") + (0.1 ":alice!~alice@example.com PRIVMSG #bar :hi")) diff --git a/test/lisp/erc/erc-d/erc-d-self-resources/no-match.eld b/test/lisp/erc/erc-d/erc-d-self-resources/no-match.eld new file mode 100644 index 0000000000..d147be1e08 --- /dev/null +++ b/test/lisp/erc/erc-d/erc-d-self-resources/no-match.eld @@ -0,0 +1,32 @@ +;;; -*- mode: lisp-data -*- + +((pass 10.0 "PASS " (? ?:) "changeme")) +((nick 0.2 "NICK tester")) + +((user 0.2 "USER user 0 * :tester") + (0 ":irc.example.org 001 tester :Welcome to the Internet Relay Network tester") + (0 ":irc.example.org 002 tester :Your host is irc.example.org") + (0 ":irc.example.org 003 tester :This server was created just now") + (0 ":irc.example.org 004 tester irc.example.org BERios CEIRabehiklmnoqstv Iabehkloqv") + (0 ":irc.example.org 005 tester MODES NETWORK=ExampleOrg NICKLEN=32 PREFIX=(qaohv)~&@%+" + " :are supported by this server") + (0 ":irc.example.org 251 tester :There are 3 users and 0 invisible on 1 server(s)") + (0 ":irc.example.org 252 tester 0 :IRC Operators online") + (0 ":irc.example.org 253 tester 0 :unregistered connections") + (0 ":irc.example.org 254 tester 1 :channels formed") + (0 ":irc.example.org 255 tester :I have 3 clients and 0 servers") + (0 ":irc.example.org 265 tester 3 3 :Current local users 3, max 3") + (0 ":irc.example.org 266 tester 3 3 :Current global users 3, max 3") + (0 ":irc.example.org 422 tester :MOTD File is missing")) + +((mode-user 1.2 "MODE tester +i") + (0 ":irc.example.org 221 tester +Zi") + (0 ":irc.example.org 306 tester :You have been marked as being away")) + +((join 1.2 "JOIN #chan") + (0 ":tester!~tester@localhost JOIN #chan") + (0 ":irc.example.org 353 alice = #chan :+alice!~alice@example.com @%+bob!~bob@example.org") + (0 ":irc.example.org 366 alice #chan :End of NAMES list")) + +((mode-chan 0.2 "MODE #chan") + (0.1 ":bob!~bob@example.org PRIVMSG #chan :hey")) diff --git a/test/lisp/erc/erc-d/erc-d-self-resources/no-pong.eld b/test/lisp/erc/erc-d/erc-d-self-resources/no-pong.eld new file mode 100644 index 0000000000..30cd805d76 --- /dev/null +++ b/test/lisp/erc/erc-d/erc-d-self-resources/no-pong.eld @@ -0,0 +1,27 @@ +;;; -*- mode: lisp-data -*- + +((pass 10.0 "PASS " (? ?:) "changeme")) +((nick 0.2 "NICK tester")) + +((~ping 1.2 "PING " nonce) + (0.1 ":irc.example.org PONG irc.example.com " echo)) + +((user 0.2 "USER user 0 * :tester") + (0 ":irc.example.org 001 tester :Welcome to the Internet Relay Network tester") + (0 ":irc.example.org 002 tester :Your host is irc.example.org") + (0 ":irc.example.org 003 tester :This server was created just now") + (0 ":irc.example.org 004 tester irc.example.org BERios CEIRabehiklmnoqstv Iabehkloqv") + (0 ":irc.example.org 005 tester MODES NETWORK=ExampleOrg NICKLEN=32 PREFIX=(qaohv)~&@%+" + " :are supported by this server") + (0 ":irc.example.org 251 tester :There are 3 users and 0 invisible on 1 server(s)") + (0 ":irc.example.org 252 tester 0 :IRC Operators online") + (0 ":irc.example.org 253 tester 0 :unregistered connections") + (0 ":irc.example.org 254 tester 1 :channels formed") + (0 ":irc.example.org 255 tester :I have 3 clients and 0 servers") + (0 ":irc.example.org 265 tester 3 3 :Current local users 3, max 3") + (0 ":irc.example.org 266 tester 3 3 :Current global users 3, max 3") + (0 ":irc.example.org 422 tester :MOTD File is missing")) + +((mode-user 1.2 "MODE tester +i") + (0 ":irc.example.org 221 tester +Zi") + (0 ":irc.example.org 306 tester :You have been marked as being away")) diff --git a/test/lisp/erc/erc-d/erc-d-self-resources/nonstandard.eld b/test/lisp/erc/erc-d/erc-d-self-resources/nonstandard.eld new file mode 100644 index 0000000000..c9cd608e6b --- /dev/null +++ b/test/lisp/erc/erc-d/erc-d-self-resources/nonstandard.eld @@ -0,0 +1,6 @@ +;;; -*- mode: lisp-data -*- +((one 1 "ONE one")) +((two 1 "TWO two")) +((blank 1 "")) +((one-space 1 " ")) +((two-spaces 1 " ")) diff --git a/test/lisp/erc/erc-d/erc-d-self-resources/proxy-barnet.eld b/test/lisp/erc/erc-d/erc-d-self-resources/proxy-barnet.eld new file mode 100644 index 0000000000..e74d20d5b3 --- /dev/null +++ b/test/lisp/erc/erc-d/erc-d-self-resources/proxy-barnet.eld @@ -0,0 +1,24 @@ +;;; -*- mode: lisp-data -*- + +((pass 10.0 "PASS " (? ?:) network ":changeme")) +((nick 1.2 "NICK tester")) + +((user 1.2 "USER user 0 * :tester") + (0.001 ":" fqdn " 001 tester :Welcome to the BAR Network tester") + (0.002 ":" fqdn " 002 tester :Your host is " fqdn) + (0.003 ":" fqdn " 003 tester :This server was created just now") + (0.004 ":" fqdn " 004 tester " fqdn " BERios CEIRabehiklmnoqstv Iabehkloqv") + (0.005 ":" fqdn " 005 tester MODES NETWORK=" net " NICKLEN=32 PREFIX=(qaohv)~&@%+" + " :are supported by this server") + (0.006 ":" fqdn " 251 tester :There are 3 users and 0 invisible on 1 server(s)") + (0.007 ":" fqdn " 252 tester 0 :IRC Operators online") + (0.008 ":" fqdn " 253 tester 0 :unregistered connections") + (0.009 ":" fqdn " 254 tester 1 :channels formed") + (0.010 ":" fqdn " 255 tester :I have 3 clients and 0 servers") + (0.011 ":" fqdn " 265 tester 3 3 :Current local users 3, max 3") + (0.012 ":" fqdn " 266 tester 3 3 :Current global users 3, max 3") + (0.013 ":" fqdn " 422 tester :MOTD File is missing")) + +((mode-user 1.2 "MODE tester +i") + (0.014 ":" fqdn " 221 tester +Zi") + (0.015 ":" fqdn " 306 tester :You have been marked as being away")) diff --git a/test/lisp/erc/erc-d/erc-d-self-resources/proxy-foonet.eld b/test/lisp/erc/erc-d/erc-d-self-resources/proxy-foonet.eld new file mode 100644 index 0000000000..cc2e9d253c --- /dev/null +++ b/test/lisp/erc/erc-d/erc-d-self-resources/proxy-foonet.eld @@ -0,0 +1,24 @@ +;;; -*- mode: lisp-data -*- + +((pass 10.0 "PASS " (? ?:) network ":changeme")) +((nick 1.2 "NICK tester")) + +((user 2.2 "USER user 0 * :tester") + (0.015 ":" fqdn " 001 tester :Welcome to the FOO Network tester") + (0.014 ":" fqdn " 002 tester :Your host is " fqdn) + (0.013 ":" fqdn " 003 tester :This server was created just now") + (0.012 ":" fqdn " 004 tester " fqdn " BERios CEIRabehiklmnoqstv Iabehkloqv") + (0.011 ":" fqdn " 005 tester MODES NETWORK=" net " NICKLEN=32 PREFIX=(qaohv)~&@%+" + " :are supported by this server") + (0.010 ":" fqdn " 251 tester :There are 3 users and 0 invisible on 1 server(s)") + (0.009 ":" fqdn " 252 tester 0 :IRC Operators online") + (0.008 ":" fqdn " 253 tester 0 :unregistered connections") + (0.007 ":" fqdn " 254 tester 1 :channels formed") + (0.006 ":" fqdn " 255 tester :I have 3 clients and 0 servers") + (0.005 ":" fqdn " 265 tester 3 3 :Current local users 3, max 3") + (0.004 ":" fqdn " 266 tester 3 3 :Current global users 3, max 3") + (0.003 ":" fqdn " 422 tester :MOTD File is missing")) + +((mode-user 1.2 "MODE tester +i") + (0.002 ":" fqdn " 221 tester +Zi") + (0.001 ":" fqdn " 306 tester :You have been marked as being away")) diff --git a/test/lisp/erc/erc-d/erc-d-self-resources/proxy-solo.eld b/test/lisp/erc/erc-d/erc-d-self-resources/proxy-solo.eld new file mode 100644 index 0000000000..af216c80ed --- /dev/null +++ b/test/lisp/erc/erc-d/erc-d-self-resources/proxy-solo.eld @@ -0,0 +1,9 @@ +;;; -*- mode: lisp-data -*- + +((pass 10.0 "PASS " (? ?:) "changeme")) +((nick 0.2 "NICK tester")) + +((user 0.2 "USER user 0 * :" (group (+ alpha)) eos) + (0 ":*status!znc@znc.in NOTICE " nick " :You have no networks configured." + " Use /znc AddNetwork to add one.") + (0 ":irc.znc.in 001 " nick " :Welcome " nick "!")) diff --git a/test/lisp/erc/erc-d/erc-d-self-resources/proxy-subprocess.el b/test/lisp/erc/erc-d/erc-d-self-resources/proxy-subprocess.el new file mode 100644 index 0000000000..6e4624050a --- /dev/null +++ b/test/lisp/erc/erc-d/erc-d-self-resources/proxy-subprocess.el @@ -0,0 +1,26 @@ +;;; proxy-subprocess.el --- Example setup file for erc-d +;;; Commentary: +;;; Code: + +(defvar erc-d-spec-vars) + +(setq erc-d-spec-vars + + (list + (cons 'fqdn (lambda (helper) + (let ((name (funcall helper :dialog-name))) + (funcall helper :set + (if (eq name 'proxy-foonet) + "irc.foo.net" + "irc.bar.net"))))) + + (cons 'net (lambda (helper) + (let ((name (funcall helper :dialog-name))) + (funcall helper :set + (if (eq name 'proxy-foonet) + "FooNet" + "BarNet"))))) + + (cons 'network '(group (+ alpha))))) + +;;; proxy-subprocess.el ends here diff --git a/test/lisp/erc/erc-d/erc-d-self-resources/timeout.eld b/test/lisp/erc/erc-d/erc-d-self-resources/timeout.eld new file mode 100644 index 0000000000..9cfad4fa8c --- /dev/null +++ b/test/lisp/erc/erc-d/erc-d-self-resources/timeout.eld @@ -0,0 +1,27 @@ +;;; -*- mode: lisp-data -*- + +((pass 10.0 "PASS " (? ?:) "changeme")) +((nick 0.2 "NICK tester")) + +((user 0.2 "USER user 0 * :tester") + (0 ":irc.example.org 001 tester :Welcome to the Internet Relay Network tester") + (0 ":irc.example.org 002 tester :Your host is irc.example.org") + (0 ":irc.example.org 003 tester :This server was created just now") + (0 ":irc.example.org 004 tester irc.example.org BERios CEIRabehiklmnoqstv Iabehkloqv") + (0 ":irc.example.org 005 tester MODES NETWORK=ExampleOrg NICKLEN=32 PREFIX=(qaohv)~&@%+" + " :are supported by this server") + (0 ":irc.example.org 251 tester :There are 3 users and 0 invisible on 1 server(s)") + (0 ":irc.example.org 252 tester 0 :IRC Operators online") + (0 ":irc.example.org 253 tester 0 :unregistered connections") + (0 ":irc.example.org 254 tester 1 :channels formed") + (0 ":irc.example.org 255 tester :I have 3 clients and 0 servers") + (0 ":irc.example.org 265 tester 3 3 :Current local users 3, max 3") + (0 ":irc.example.org 266 tester 3 3 :Current global users 3, max 3") + (0 ":irc.example.org 422 tester :MOTD File is missing")) + +((mode-user 1.2 "MODE tester +i") + (0 ":irc.example.org 221 tester +Zi") + (0 ":irc.example.org 306 tester :You have been marked as being away")) + +((mode 0.2 "MODE #chan") + (0.1 ":bob!~bob@example.org PRIVMSG #chan :hey")) diff --git a/test/lisp/erc/erc-d/erc-d-self-resources/unexpected.eld b/test/lisp/erc/erc-d/erc-d-self-resources/unexpected.eld new file mode 100644 index 0000000000..ac0a8fecfa --- /dev/null +++ b/test/lisp/erc/erc-d/erc-d-self-resources/unexpected.eld @@ -0,0 +1,28 @@ +;;; -*- mode: lisp-data -*- +((t 10.0 "PASS " (? ?:) "changeme")) +((t 0.2 "NICK tester")) + +((t 0.2 "USER user 0 * :tester") + (0.0 ":irc.example.org 001 tester :Welcome to the Internet Relay Network tester") + (0.0 ":irc.example.org 002 tester :Your host is irc.example.org") + (0.0 ":irc.example.org 003 tester :This server was created just now") + (0.0 ":irc.example.org 004 tester irc.example.org BERios CEIRabehiklmnoqstv Iabehkloqv") + (0.0 ":irc.example.org 005 tester MODES NETWORK=ExampleOrg NICKLEN=32 PREFIX=(qaohv)~&@%+" + " :are supported by this server") + (0.0 ":irc.example.org 251 tester :There are 3 users and 0 invisible on 1 server(s)") + (0.0 ":irc.example.org 252 tester 0 :IRC Operators online") + (0.0 ":irc.example.org 253 tester 0 :unregistered connections") + (0.0 ":irc.example.org 254 tester 1 :channels formed") + (0.0 ":irc.example.org 255 tester :I have 3 clients and 0 servers") + (0.0 ":irc.example.org 265 tester 3 3 :Current local users 3, max 3") + (0.0 ":irc.example.org 266 tester 3 3 :Current global users 3, max 3") + (0.0 ":irc.example.org 422 tester :MOTD File is missing")) + +((mode-user 1.2 "MODE tester +i") + (0.0 ":irc.example.org 221 tester +Zi") + + (0.0 ":irc.example.org 306 tester :You have been marked as being away") + (0.0 ":tester!~tester@localhost JOIN #chan") + (0.0 ":irc.example.org 353 alice = #chan :+alice!~alice@example.com @%+bob!~bob@example.org") + (0.0 ":irc.example.org 366 alice #chan :End of NAMES list") + (0.1 ":bob!~bob@example.org PRIVMSG #chan :hey")) diff --git a/test/lisp/erc/erc-d/erc-d-self.el b/test/lisp/erc/erc-d/erc-d-self.el new file mode 100644 index 0000000000..c5b8f15cb2 --- /dev/null +++ b/test/lisp/erc/erc-d/erc-d-self.el @@ -0,0 +1,1307 @@ +;;; erc-d-self.el --- tests for erc-d -*- lexical-binding: t -*- + +;; This file is part of GNU Emacs. +;; +;; This program is free software: you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see +;; . + +;;; Commentary: +;; +;; This file tests the dumb server itself. The file name does not end +;; in "-tests.el" because test/Makefile looks for corresponding +;; library files and raises an error when one isn't found. + +;;; Code: +(require 'ert-x) +(eval-and-compile (let ((dir (getenv "EMACS_TEST_DIRECTORY"))) + (when dir + (load (concat dir "/lisp/erc/erc-d/erc-d") nil t) + (load (concat dir "/lisp/erc/erc-d/erc-d-t") nil t)))) + +(require 'erc-d) +(require 'erc-d-t) +(require 'erc-backend) + +(ert-deftest erc-d-u--canned-load-dialog--basic () + (should-not (get-buffer "basic.eld")) + (should-not erc-d-u--canned-buffers) + (let* ((exes (erc-d-u--canned-load-dialog 'basic)) + (reap (lambda () + (cl-loop with e = (erc-d-u--read-dialog exes) + for s = (erc-d-u--read-exchange e) + while s collect s)))) + (should (get-buffer "basic.eld")) + (should (memq (get-buffer "basic.eld") erc-d-u--canned-buffers)) + (should (equal (funcall reap) '((pass 10.0 "PASS " (? ?:) "changeme")))) + (should (equal (funcall reap) '((nick 0.2 "NICK tester")))) + (let ((r (funcall reap))) + (should (equal (car r) '(user 0.2 "USER user 0 * :tester"))) + (should (equal + (car (last r)) + '(0 ":irc.example.org 422 tester :MOTD File is missing")))) + (should (equal (car (funcall reap)) '(mode-user 1.2 "MODE tester +i"))) + (should (equal (funcall reap) + '((mode-chan 1.2 "MODE #chan") + (0.1 ":bob!~bob@example.org PRIVMSG #chan :hey")))) + ;; See `define-error' site for `iter-end-of-sequence' + (ert-info ("EOB detected") (should-not (erc-d-u--read-dialog exes)))) + (should-not (get-buffer "basic.eld")) + (should-not erc-d-u--canned-buffers)) + +(defun erc-d-self--make-hunk-reader (hunks) + (let ((p (erc-d-u--read-dialog hunks))) + (lambda () (erc-d-u--read-exchange p)))) + +;; Fuzzies need to be able to access any non-exhausted genny. +(ert-deftest erc-d-u--canned-load-dialog--intermingled () + (should-not (get-buffer "basic.eld")) + (should-not erc-d-u--canned-buffers) + (let* ((exes (erc-d-u--canned-load-dialog 'basic)) + (pass (erc-d-self--make-hunk-reader exes)) + (nick (erc-d-self--make-hunk-reader exes)) + (user (erc-d-self--make-hunk-reader exes)) + (modu (erc-d-self--make-hunk-reader exes)) + (modc (erc-d-self--make-hunk-reader exes))) + + (should (equal (funcall user) '(user 0.2 "USER user 0 * :tester"))) + (should (equal (funcall modu) '(mode-user 1.2 "MODE tester +i"))) + (should (equal (funcall modc) '(mode-chan 1.2 "MODE #chan"))) + + (cl-loop repeat 8 do (funcall user)) ; skip a few + (should (equal (funcall user) + '(0 ":irc.example.org 254 tester 1 :channels formed"))) + (should (equal (funcall modu) + '(0 ":irc.example.org 221 tester +Zi"))) + (should (equal (cl-loop for s = (funcall modc) while s collect s) ; done + '((0.1 ":bob!~bob@example.org PRIVMSG #chan :hey")))) + + (cl-loop repeat 3 do (funcall user)) + (cl-loop repeat 3 do (funcall modu)) + + (ert-info ("Change up the order") + (should + (equal (funcall modu) + '(0 ":irc.example.org 366 alice #chan :End of NAMES list"))) + (should + (equal (funcall user) + '(0 ":irc.example.org 422 tester :MOTD File is missing")))) + + ;; Exhaust these + (should (equal (cl-loop for s = (funcall pass) while s collect s) ; done + '((pass 10.0 "PASS " (? ?:) "changeme")))) + (should (equal (cl-loop for s = (funcall nick) while s collect s) ; done + '((nick 0.2 "NICK tester")))) + + (ert-info ("End of file but no teardown because hunks outstanding") + (should-not (erc-d-u--read-dialog exes)) + (should (get-buffer "basic.eld"))) + + ;; Finish + (should-not (funcall user)) + (should-not (funcall modu))) + + (should-not (get-buffer "basic.eld")) + (should-not erc-d-u--canned-buffers)) + +;; This indirectly tests `erc-d-u--canned-read' cleanup/teardown + +(ert-deftest erc-d-u--rewrite-for-slow-mo () + (should-not (get-buffer "basic.eld")) + (should-not (get-buffer "basic.eld<2>")) + (should-not (get-buffer "basic.eld<3>")) + (should-not erc-d-u--canned-buffers) + (let ((exes (erc-d-u--canned-load-dialog 'basic)) + (exes-lower (erc-d-u--canned-load-dialog 'basic)) + (exes-custom (erc-d-u--canned-load-dialog 'basic)) + (reap (lambda (e) (cl-loop with p = (erc-d-u--read-dialog e) + for s = (erc-d-u--read-exchange p) + while s collect s)))) + (should (get-buffer "basic.eld")) + (should (get-buffer "basic.eld<2>")) + (should (get-buffer "basic.eld<3>")) + (should (equal (list (get-buffer "basic.eld<3>") + (get-buffer "basic.eld<2>") + (get-buffer "basic.eld")) + erc-d-u--canned-buffers)) + + (ert-info ("Rewrite for slowmo basic") + (setq exes (erc-d-u--rewrite-for-slow-mo 10 exes)) + (should (equal (funcall reap exes) + '((pass 20.0 "PASS " (? ?:) "changeme")))) + (should (equal (funcall reap exes) + '((nick 10.2 "NICK tester")))) + (let ((r (funcall reap exes))) + (should (equal (car r) '(user 10.2 "USER user 0 * :tester"))) + (should (equal + (car (last r)) + '(0 ":irc.example.org 422 tester :MOTD File is missing")))) + (should (equal (car (funcall reap exes)) + '(mode-user 11.2 "MODE tester +i"))) + (should (equal (car (funcall reap exes)) + '(mode-chan 11.2 "MODE #chan"))) + (should-not (erc-d-u--read-dialog exes))) + + (ert-info ("Rewrite for slowmo bounded") + (setq exes-lower (erc-d-u--rewrite-for-slow-mo -5 exes-lower)) + (should (equal (funcall reap exes-lower) + '((pass 10.0 "PASS " (? ?:) "changeme")))) + (should (equal (funcall reap exes-lower) + '((nick 5 "NICK tester")))) + (should (equal (car (funcall reap exes-lower)) + '(user 5 "USER user 0 * :tester"))) + (should (equal (car (funcall reap exes-lower)) + '(mode-user 5 "MODE tester +i"))) + (should (equal (car (funcall reap exes-lower)) + '(mode-chan 5 "MODE #chan"))) + (should-not (erc-d-u--read-dialog exes-lower))) + + (ert-info ("Rewrite for slowmo custom") + (setq exes-custom (erc-d-u--rewrite-for-slow-mo + (lambda (n) (* 2 n)) exes-custom)) + (should (equal (funcall reap exes-custom) + '((pass 20.0 "PASS " (? ?:) "changeme")))) + (should (equal (funcall reap exes-custom) + '((nick 0.4 "NICK tester")))) + (should (equal (car (funcall reap exes-custom)) + '(user 0.4 "USER user 0 * :tester"))) + (should (equal (car (funcall reap exes-custom)) + '(mode-user 2.4 "MODE tester +i"))) + (should (equal (car (funcall reap exes-custom)) + '(mode-chan 2.4 "MODE #chan"))) + (should-not (erc-d-u--read-dialog exes-custom)))) + + (should-not (get-buffer "basic.eld")) + (should-not (get-buffer "basic.eld<2>")) + (should-not (get-buffer "basic.eld<3>")) + (should-not erc-d-u--canned-buffers)) + +(ert-deftest erc-d--active-ex-p () + (let ((ring (make-ring 5))) + (ert-info ("Empty ring returns nil for not active") + (should-not (erc-d--active-ex-p ring))) + (ert-info ("One fuzzy member returns nil for not active") + (ring-insert ring (make-erc-d-exchange :tag '~foo)) + (should-not (erc-d--active-ex-p ring))) + (ert-info ("One active member returns t for active") + (ring-insert-at-beginning ring (make-erc-d-exchange :tag 'bar)) + (should (erc-d--active-ex-p ring))))) + +(defun erc-d-self--parse-message-upstream (raw) + "Hack shim for parsing RAW line recvd from peer." + (cl-letf (((symbol-function #'erc-handle-parsed-server-response) + (lambda (_ p) p))) + (let ((erc-active-buffer nil)) + (erc-parse-server-response nil raw)))) + +(ert-deftest erc-d-i--validate-tags () + (should (erc-d-i--validate-tags + (concat "batch=4cc99692bf24a4bec4aa03da437364f5;" + "time=2021-01-04T00:32:13.839Z"))) + (should (erc-d-i--validate-tags "+foo=bar;baz=spam")) + (should (erc-d-i--validate-tags "foo=\\:ok;baz=\\s")) + (should (erc-d-i--validate-tags "foo=\303\247edilla")) + (should (erc-d-i--validate-tags "foo=\\")) + (should (erc-d-i--validate-tags "foo=bar\\baz")) + (should-error (erc-d-i--validate-tags "foo=\\\\;baz=\\\r\\\n")) + (should-error (erc-d-i--validate-tags "foo=\n")) + (should-error (erc-d-i--validate-tags "foo=\0ok")) + (should-error (erc-d-i--validate-tags "foo=bar baz")) + (should-error (erc-d-i--validate-tags "foo=bar\r")) + (should-error (erc-d-i--validate-tags "foo=bar;"))) + +(ert-deftest erc-d-i--parse-message () + (let* ((raw (concat "@time=2020-11-23T09:10:33.088Z " + ":tilde.chat BATCH +1 chathistory :#meta")) + (upstream (erc-d-self--parse-message-upstream raw)) + (ours (erc-d-i--parse-message raw))) + + (ert-info ("Baseline upstream") + (should (equal (erc-response.unparsed upstream) raw)) + (should (equal (erc-response.sender upstream) "tilde.chat")) + (should (equal (erc-response.command upstream) "BATCH")) + (should (equal (erc-response.command-args upstream) + '("+1" "chathistory" "#meta"))) + (should (equal (erc-response.contents upstream) "#meta"))) + + (ert-info ("Ours my not compare cl-equalp but is otherwise the same") + (should (equal (erc-d-i-message.unparsed ours) raw)) + (should (equal (erc-d-i-message.sender ours) "tilde.chat")) + (should (equal (erc-d-i-message.command ours) "BATCH")) + (should (equal (erc-d-i-message.command-args ours) + '("+1" "chathistory" "#meta"))) + (should (equal (erc-d-i-message.contents ours) "#meta")) + (should (equal (erc-d-i-message.tags ours) + '((time . "2020-11-23T09:10:33.088Z"))))) + + (ert-info ("No compat decodes the whole message as utf-8") + (setq ours (erc-d-i--parse-message + "@foo=\303\247edilla TAGMSG #ch\303\240n" + 'decode)) + (should-not (erc-d-i-message.compat ours)) + (should (equal (erc-d-i-message.command-args ours) '("#chàn"))) + (should (equal (erc-d-i-message.contents ours) "")) + (should (equal (erc-d-i-message.tags ours) '((foo . "çedilla"))))))) + +(ert-deftest erc-d-i--unescape-tag-value () + (should (equal (erc-d-i--unescape-tag-value + "\\sabc\\sdef\\s\\sxyz\\s") + " abc def xyz ")) + (should (equal (erc-d-i--unescape-tag-value + "\\\\abc\\\\def\\\\\\\\xyz\\\\") + "\\abc\\def\\\\xyz\\")) + (should (equal (erc-d-i--unescape-tag-value "a\\bc") "abc")) + (should (equal (erc-d-i--unescape-tag-value + "\\\\abc\\\\def\\\\\\\\xyz\\") + "\\abc\\def\\\\xyz")) + (should (equal (erc-d-i--unescape-tag-value "a\\:b\\r\\nc\\sd") + "a;b\r\nc d"))) + +(ert-deftest erc-d-i--escape-tag-value () + (should (equal (erc-d-i--escape-tag-value " abc def xyz ") + "\\sabc\\sdef\\s\\sxyz\\s")) + (should (equal (erc-d-i--escape-tag-value "\\abc\\def\\\\xyz\\") + "\\\\abc\\\\def\\\\\\\\xyz\\\\")) + (should (equal (erc-d-i--escape-tag-value "a;b\r\nc d") + "a\\:b\\r\\nc\\sd"))) + +;; TODO add tests for msg-join, mask-match, userhost-split, +;; validate-hostname + +(ert-deftest erc-d-i--parse-message--irc-parser-tests () + (let* ((data (with-temp-buffer + (insert-file-contents + (ert-resource-file "irc-parser-tests.eld")) + (read (current-buffer)))) + (tests (assoc-default 'tests (assoc-default 'msg-split data))) + input atoms m ours) + (dolist (test tests) + (setq input (assoc-default 'input test) + atoms (assoc-default 'atoms test) + m (erc-d-i--parse-message input)) + (ert-info ("Parses tags correctly") + (setq ours (erc-d-i-message.tags m)) + (if-let ((tags (assoc-default 'tags atoms))) + (pcase-dolist (`(,key . ,value) ours) + (should (string= (cdr (assq key tags)) (or value "")))) + (should-not ours))) + (ert-info ("Parses verbs correctly") + (setq ours (erc-d-i-message.command m)) + (if-let ((verbs (assoc-default 'verb atoms))) + (should (string= (downcase verbs) (downcase ours))) + (should (string-empty-p ours)))) + (ert-info ("Parses sources correctly") + (setq ours (erc-d-i-message.sender m)) + (if-let ((source (assoc-default 'source atoms))) + (should (string= source ours)) + (should (string-empty-p ours)))) + (ert-info ("Parses params correctly") + (setq ours (erc-d-i-message.command-args m)) + (if-let ((params (assoc-default 'params atoms))) + (should (equal ours params)) + (should-not ours)))))) + +(defun erc-d-self--new-ex (existing raw-hunk) + (let* ((f (lambda (_) (pop raw-hunk))) + (sd (make-erc-d-u-scan-d :f f))) + (setf (erc-d-exchange-hunk existing) (make-erc-d-u-scan-e :sd sd) + (erc-d-exchange-spec existing) (make-erc-d-spec))) + (erc-d--iter existing)) + +(ert-deftest erc-d--render-entries () + (let* ((dialog (make-erc-d-dialog :vars `((:a . 1) + (c . ((a b) (: a space b))) + (d . (c alpha digit)) + (bee . 2) + (f . ,(lambda () "3")) + (i . emacs-pid)))) + (exchange (make-erc-d-exchange :dialog dialog)) + (mex (apply-partially #'erc-d-self--new-ex exchange)) + it) + + (erc-d-exchange-reload dialog exchange) + + (ert-info ("Baseline Outgoing") + (setq it (funcall mex '((0 "abc")))) + (should (equal (funcall it) 0)) + (should (equal (funcall it) "abc"))) + + (ert-info ("Incoming are regexp escaped") + (setq it (funcall mex '((i 0.0 "fsf" ".org")))) + (should (equal (cons (funcall it) (funcall it)) '(i . 0.0))) + (should (equal (funcall it) "\\`fsf\\.org"))) + + (ert-info ("Incoming can access vars via rx-let") + (setq it (funcall mex '((i 0.0 bee)))) + (should (equal (cons (funcall it) (funcall it)) '(i . 0.0))) + (should (equal (funcall it) "\\`\002"))) + + (ert-info ("Incoming rx-let params") + (setq it (funcall mex '((i 0.0 d)))) + (should (equal (cons (funcall it) (funcall it)) '(i . 0.0))) + (should (equal (funcall it) "\\`[[:alpha:]][[:space:]][[:digit:]]"))) + + (ert-info ("Incoming literal rx forms") + (setq it (funcall mex '((i 0.0 (= 3 alpha) ".org")))) + (should (equal (cons (funcall it) (funcall it)) '(i . 0.0))) + (should (equal (funcall it) "\\`[[:alpha:]]\\{3\\}\\.org"))) + + (ert-info ("Self-quoting disallowed") + (setq it (funcall mex '((0 :a "abc")))) + (should (equal (funcall it) 0)) + (should-error (funcall it))) + + (ert-info ("Outgoing mixed") + (setq it (funcall mex + '((0 (format "%s" (not (zerop i))) (string bee) f)))) + (should (equal (funcall it) 0)) + (should (equal (funcall it) "t\0023"))) + + (ert-info ("Exits clean") + (when (listp (alist-get 'f (erc-d-dialog-vars dialog))) ; may be compiled + (should (eq 'closure (car (alist-get 'f (erc-d-dialog-vars dialog)))))) + (should-not (funcall it)) + (should (equal (erc-d-dialog-vars dialog) + `((:a . 1) + (c . ((a b) (: a space b))) + (d . (c alpha digit)) + (bee . 2) + (f . ,(alist-get 'f (erc-d-dialog-vars dialog))) + (i . emacs-pid))))))) + +(ert-deftest erc-d--render-entries--matches () + (let* ((alist (list + (cons 'f (lambda (a) (funcall a :match 1))) + (cons 'g (lambda () (match-string 2 "foo bar baz"))) + (cons 'h (lambda (a) (concat (funcall a :match 0) + (funcall a :request)))) + (cons 'i (lambda (_ e) (erc-d-exchange-request e))) + (cons 'j (lambda () + (set-match-data '(0 1)) + (match-string 0 "j"))))) + (dialog (make-erc-d-dialog :vars alist)) + (exchange (make-erc-d-exchange :dialog dialog + :request "foo bar baz" + ;; 11 222 + :match-data '(4 11 4 6 8 11))) + (mex (apply-partially #'erc-d-self--new-ex exchange)) + it) + + (erc-d-exchange-reload dialog exchange) + + (ert-info ("Baseline outgoing") + (setq it (funcall mex '((0 :request)))) + (should (equal (funcall it) 0)) + (should-error (funcall it))) + + (ert-info ("One arg, match") + (setq it (funcall mex '((0 f)))) + (should (equal (funcall it) 0)) + (should (equal (funcall it) "ba"))) + + (ert-info ("No args") + (setq it (funcall mex '((0 g)))) + (should (equal (funcall it) 0)) + (should (equal (funcall it) "baz"))) + + (ert-info ("Second arg is exchange object") + (setq it (funcall mex '((0 i)))) + (should (equal (funcall it) 0)) + (should (equal (funcall it) "foo bar baz"))) + + (ert-info ("One arg, multiple calls") + (setq it (funcall mex '((0 h)))) + (should (equal (funcall it) 0)) + (should (equal (funcall it) "bar bazfoo bar baz"))) + + (ert-info ("Match data restored") + (setq it (funcall mex '((0 j)))) + (should (equal (funcall it) 0)) + (should (equal (funcall it) "j")) + + (setq it (funcall mex '((0 g)))) + (should (equal (funcall it) 0)) + (should (equal (funcall it) "baz"))) + + (ert-info ("Bad signature") + (let ((qlist (list 'f '(lambda (p q x) (ignore))))) + (setf (erc-d-dialog-vars dialog) qlist) + (should-error (erc-d-exchange-reload dialog exchange)))))) + +(ert-deftest erc-d--render-entries--dynamic () + (let* ((alist (list + (cons 'foo "foo") '(f . (lambda () foo)) + (cons 'g '(lambda (a) (funcall a :rebind 'g f) "bar")) + (cons 'j (lambda (a) (funcall a :set "123") "abc")) + (cons 'k (lambda () "abc")))) + (dialog (make-erc-d-dialog :vars alist)) + (exchange (make-erc-d-exchange :dialog dialog)) + (mex (apply-partially #'erc-d-self--new-ex exchange)) + it) + + (erc-d-exchange-reload dialog exchange) + + (ert-info ("Initial reference calls function") + (setq it (funcall mex '((0 j) (0 j)))) + (should (equal (funcall it) 0)) + (should (equal (funcall it) "abc"))) + + (ert-info ("Subsequent reference expands to string") + (should (equal (funcall it) 0)) + (should (equal (funcall it) "123"))) + + (ert-info ("Outside manipulation: initial reference calls function") + (setq it (funcall mex '((0 k) (0 k)))) + (should (equal (funcall it) 0)) + (should (equal (funcall it) "abc"))) + + (ert-info ("Outside manipulation: subsequent reference expands to string") + (erc-d-exchange-rebind dialog exchange 'k "123") + (should (equal (funcall it) 0)) + (should (equal (funcall it) "123"))) + + (ert-info ("Swap one function for another") + (setq it (funcall mex '((0 g) (0 g)))) + (should (equal (funcall it) 0)) + (should (equal (funcall it) "bar")) + (should (equal (funcall it) 0)) + (should (equal (funcall it) "foo"))) + + (ert-info ("Bindings accessible inside functions") ; anti-feature? + (setq it (funcall mex '((0 f)))) + (should (equal (funcall it) 0)) + (should (equal (funcall it) "foo"))) + + (ert-info ("Rebuild alist by sending flag") + (setq it (funcall mex '((0 f) (1 f) (2 f) (i 3 f)))) + (should (equal (funcall it) 0)) + (should (equal (funcall it) "foo")) + (erc-d-exchange-rebind dialog exchange 'f "bar") + (should (equal (funcall it) 1)) + (should (equal (funcall it) "bar")) + (setq alist (setf (alist-get 'f (erc-d-dialog-vars dialog)) + (lambda nil "baz"))) + (should (eq (funcall it) 2)) + (should (equal (funcall it 'reload) "baz")) + (setq alist (setf (alist-get 'f (erc-d-dialog-vars dialog)) "spam")) + (should (eq (funcall it) 'i)) + (should (eq (funcall it 'reload) 3)) + (should (equal (funcall it) "\\`spam"))))) + +(ert-deftest erc-d-t-with-cleanup () + (should-not (get-buffer "*echo*")) + (should-not (get-buffer "*foo*")) + (should-not (get-buffer "*bar*")) + (should-not (get-buffer "*baz*")) + (erc-d-t-with-cleanup + ((echo (start-process "echo" (get-buffer-create "*echo*") "sleep" "1")) + (buffer-foo (get-buffer-create "*foo*")) + (buffer-bar (get-buffer-create "*bar*")) + (clean-up (list (intern (process-name echo)))) ; let* + buffer-baz) + (ert-info ("Clean Up") + (should (equal clean-up '(ran echo))) + (should (bufferp buffer-baz)) + (should (bufferp buffer-foo)) + (setq buffer-foo nil)) + (setq buffer-baz (get-buffer-create "*baz*")) + (push 'ran clean-up)) + (ert-info ("Buffers and procs destroyed") + (should-not (get-buffer "*echo*")) + (should-not (get-buffer "*bar*")) + (should-not (get-buffer "*baz*"))) + (ert-info ("Buffer foo spared") + (should (get-buffer "*foo*")) + (kill-buffer "*foo*"))) + +(defvar erc-d-self-with-server-password "changeme") + +;; Compromise between removing `autojoin' from `erc-modules' entirely +;; and allowing side effects to meddle excessively +(defvar erc-autojoin-channels-alist) + +;; This is only meant to be used by tests in this file. +(cl-defmacro erc-d-self-with-server ((dumb-server-var erc-server-buffer-var) + dialog &rest body) + "Create server for DIALOG and run BODY. +DIALOG may also be a list of dialogs. ERC-SERVER-BUFFER-VAR and +DUMB-SERVER-VAR are bound accordingly in BODY." + (declare (indent 2)) + (when (eq '_ dumb-server-var) + (setq dumb-server-var (make-symbol "dumb-server-var"))) + (when (eq '_ erc-server-buffer-var) + (setq erc-server-buffer-var (make-symbol "erc-server-buffer-var"))) + (if (listp dialog) + (setq dialog (mapcar (lambda (f) (list 'quote f)) dialog)) + (setq dialog `((quote ,dialog)))) + `(let* (auth-source-do-cache + (,dumb-server-var (erc-d-run "localhost" t ,@dialog)) + ,erc-server-buffer-var + ;; + (erc-server-flood-penalty 0.05) + erc-autojoin-channels-alist + erc-server-auto-reconnect) + (should-not erc-d--slow-mo) + (with-current-buffer "*erc-d-server*" (erc-d-t-search-for 4 "Starting")) + ;; Allow important messages through, even in -batch mode. + (advice-add #'erc-handle-login :around #'erc-d-t-silence-around) + (advice-add #'erc-server-connect :around #'erc-d-t-silence-around) + (unless (or noninteractive erc-debug-irc-protocol) + (erc-toggle-debug-irc-protocol)) + (setq ,erc-server-buffer-var + (erc :server "localhost" + :password erc-d-self-with-server-password + :port (process-contact ,dumb-server-var :service) + :nick "tester" + :full-name "tester")) + (unwind-protect + (progn + ,@body + (erc-d-t-wait-for 1 "dumb-server death" + (not (process-live-p ,dumb-server-var)))) + (when (process-live-p erc-server-process) + (delete-process erc-server-process)) + (advice-remove #'erc-handle-login #'erc-d-t-silence-around) + (advice-remove #'erc-server-connect #'erc-d-t-silence-around) + (when noninteractive + (kill-buffer ,erc-server-buffer-var) + (erc-d-t-kill-related-buffers))))) + +(defmacro erc-d-self-with-failure-spy (found func-syms &rest body) + "Wrap functions with advice for inspecting errors caused by BODY. +Do this for functions whose names appear in FUNC-SYMS. When running +advice code, add errors to list FOUND. Note: the teardown finalizer is +not added by default. Also, `erc-d-linger-secs' likely has to +be nonzero for this to work." + (declare (indent 2)) + ;; Catch errors thrown by timers that `should-error'ignores + `(progn + (cl-labels ((ad (f o &rest r) + (condition-case err + (apply o r) + (error (push err ,found) + (advice-remove f 'spy))))) + (dolist (sym ,func-syms) + (advice-add sym :around (apply-partially #'ad sym) '((name . spy)))) + (progn ,@body)) + (setq ,found (nreverse ,found)) + (dolist (sym ,func-syms) + (advice-remove sym 'spy)))) + +(ert-deftest erc-d-run-nonstandard-messages () + (let* ((erc-d-linger-secs 0.2) + (dumb-server (erc-d-run "localhost" t 'nonstandard)) + (dumb-server-buffer (get-buffer "*erc-d-server*")) + (expect (erc-d-t-make-expecter)) + client) + (with-current-buffer "*erc-d-server*" (erc-d-t-search-for 4 "Starting")) + (setq client (open-network-stream "erc-d-client" nil + "localhost" + (process-contact dumb-server :service) + :coding 'binary)) + (ert-info ("Server splits CRLF delimited lines") + (process-send-string client "ONE one\r\nTWO two\r\n") + (with-current-buffer dumb-server-buffer + (funcall expect 1 '(: "<- nonstandard:" (+ digit) " ONE one" eol)) + (funcall expect 1 '(regex "<- nonstandard:[[:digit:]]+ TWO two$")))) + (ert-info ("Server doesn't discard empty lines") + (process-send-string client "\r\n") + (with-current-buffer dumb-server-buffer + (funcall expect 1 '(regex "<- nonstandard:[[:digit:]]+ $")))) + (ert-info ("Server preserves spaces") + (process-send-string client " \r\n") + (with-current-buffer dumb-server-buffer + (funcall expect 1 '(regex "<- nonstandard:[[:digit:]]+ \\{2\\}$"))) + (process-send-string client " \r\n") + (with-current-buffer dumb-server-buffer + (funcall expect 1 '(regex "<- nonstandard:[[:digit:]]+ \\{3\\}$")))) + (erc-d-t-wait-for 3 "dumb-server death" + (not (process-live-p dumb-server))) + (delete-process client) + (when noninteractive + (kill-buffer dumb-server-buffer)))) + +(ert-deftest erc-d-run-basic () + (erc-d-self-with-server (_ _) basic + (with-current-buffer (erc-d-t-wait-for 3 (get-buffer "#chan")) + (erc-d-t-search-for 2 "hey")) + (when noninteractive + (kill-buffer "#chan")))) + +(ert-deftest erc-d-run-eof () + (skip-unless noninteractive) + (erc-d-self-with-server (_ erc-s-buf) eof + (with-current-buffer (erc-d-t-wait-for 3 (get-buffer "#chan")) + (erc-d-t-search-for 2 "hey")) + (with-current-buffer erc-s-buf + (process-send-eof erc-server-process)))) + +(ert-deftest erc-d-run-eof-fail () + (let (errors) + (erc-d-self-with-failure-spy errors '(erc-d--teardown) + (erc-d-self-with-server (_ _) eof + (with-current-buffer (erc-d-t-wait-for 5 (get-buffer "#chan")) + (erc-d-t-search-for 2 "hey")) + (erc-d-t-wait-for 10 errors))) + (should (string-match-p "Timed out awaiting request.*__EOF__" + (cadr (pop errors)))))) + +(ert-deftest erc-d-run-linger () + (erc-d-self-with-server (dumb-s _) linger + (with-current-buffer (erc-d-t-wait-for 3 (get-buffer "#chan")) + (erc-d-t-search-for 2 "hey")) + (with-current-buffer (process-buffer dumb-s) + (erc-d-t-search-for 2 "Lingering for 1.00 seconds")) + (with-current-buffer (process-buffer dumb-s) + (erc-d-t-search-for 3 "Lingered for 1.00 seconds")))) + +(ert-deftest erc-d-run-linger-fail () + (let ((erc-server-flood-penalty 0.1) + errors) + (erc-d-self-with-failure-spy + errors '(erc-d--teardown erc-d-command) + (erc-d-self-with-server (_ _) linger + (with-current-buffer (erc-d-t-wait-for 3 (get-buffer "#chan")) + (erc-d-t-search-for 2 "hey") + (erc-cmd-MSG "#chan hi")) + (erc-d-t-wait-for 10 "Bad match" errors))) + (should (string-match-p "Match failed.*hi" (cadr (pop errors)))))) + +(ert-deftest erc-d-run-linger-direct () + (let* ((dumb-server (erc-d-run "localhost" t + 'linger-multi-a 'linger-multi-b)) + (port (process-contact dumb-server :service)) + (dumb-server-buffer (get-buffer "*erc-d-server*")) + (client-buffer-a (get-buffer-create "*erc-d-client-a*")) + (client-buffer-b (get-buffer-create "*erc-d-client-b*")) + (start (current-time)) + client-a client-b) + (with-current-buffer "*erc-d-server*" (erc-d-t-search-for 4 "Starting")) + (setq client-a (open-network-stream "erc-d-client-a" client-buffer-a + "localhost" port + :coding 'binary) + client-b (open-network-stream "erc-d-client-b" client-buffer-b + "localhost" port + :coding 'binary)) + (process-send-string client-a "PASS :a\r\n") + (sleep-for 0.01) + (process-send-string client-b "PASS :b\r\n") + (sleep-for 0.01) + (erc-d-t-wait-for 3 "dumb-server death" + (not (process-live-p dumb-server))) + (ert-info ("Ensure linger of one second") + (should (time-less-p 1 (time-subtract (current-time) start))) + (should (time-less-p (time-subtract (current-time) start) 1.5))) + (delete-process client-a) + (delete-process client-b) + (when noninteractive + (kill-buffer client-buffer-a) + (kill-buffer client-buffer-b) + (kill-buffer dumb-server-buffer)))) + +(ert-deftest erc-d-run-drop-direct () + (let* ((dumb-server (erc-d-run "localhost" t 'drop-a 'drop-b)) + (port (process-contact dumb-server :service)) + (dumb-server-buffer (get-buffer "*erc-d-server*")) + (client-buffer-a (get-buffer-create "*erc-d-client-a*")) + (client-buffer-b (get-buffer-create "*erc-d-client-b*")) + (start (current-time)) + client-a client-b) + (with-current-buffer "*erc-d-server*" (erc-d-t-search-for 4 "Starting")) + (setq client-a (open-network-stream "erc-d-client-a" client-buffer-a + "localhost" port + :coding 'binary) + client-b (open-network-stream "erc-d-client-b" client-buffer-b + "localhost" port + :coding 'binary)) + (process-send-string client-a "PASS :a\r\n") + (sleep-for 0.01) + (process-send-string client-b "PASS :b\r\n") + (erc-d-t-wait-for 3 "client-a dies" (not (process-live-p client-a))) + (should (time-less-p (time-subtract (current-time) start) 0.32)) + (erc-d-t-wait-for 3 "dumb-server death" + (not (process-live-p dumb-server))) + (ert-info ("Ensure linger of one second") + (should (time-less-p 1 (time-subtract (current-time) start)))) + (delete-process client-a) + (delete-process client-b) + (when noninteractive + (kill-buffer client-buffer-a) + (kill-buffer client-buffer-b) + (kill-buffer dumb-server-buffer)))) + +(ert-deftest erc-d-run-no-match () + (let ((erc-d-linger-secs 1) + erc-server-auto-reconnect + errors) + (erc-d-self-with-failure-spy errors '(erc-d--teardown erc-d-command) + (erc-d-self-with-server (_ erc-server-buffer) no-match + (with-current-buffer erc-server-buffer + (erc-d-t-search-for 2 "away") + (erc-cmd-JOIN "#foo") + (erc-d-t-wait-for 10 "Bad match" errors)))) + (should (string-match-p "Match failed.*foo.*chan" (cadr (pop errors)))) + (should-not (get-buffer "#foo")))) + +(ert-deftest erc-d-run-timeout () + (let ((erc-d-linger-secs 1) + err errors) + (erc-d-self-with-failure-spy errors '(erc-d--teardown) + (erc-d-self-with-server (_ _) timeout + (erc-d-t-wait-for 10 "error caught" errors))) + (setq err (pop errors)) + (should (eq (car err) 'erc-d-timeout)) + (should (string-match-p "Timed out" (cadr err))))) + +(ert-deftest erc-d-run-unexpected () + (let ((erc-d-linger-secs 2) + errors) + (erc-d-self-with-failure-spy + errors '(erc-d--teardown erc-d-command) + (erc-d-self-with-server (_ _) unexpected + (ert-info ("All specs consumed when more input arrives") + (erc-d-t-wait-for 10 "error caught" (cdr errors))))) + (should (string-match-p "unexpected.*MODE" (cadr (pop errors)))) + ;; Nonsensical normally because func would have already exited when + ;; first error was thrown + (should (string-match-p "Match failed" (cadr (pop errors)))))) + +(ert-deftest erc-d-run-unexpected-depleted () + (let ((erc-d-linger-secs 3) + errors) + (erc-d-self-with-failure-spy errors '(erc-d--teardown erc-d-command) + (let* ((dumb-server-buffer (get-buffer-create "*erc-d-server*")) + (dumb-server (erc-d-run "localhost" t 'depleted)) + (expect (erc-d-t-make-expecter)) + (client-buf (get-buffer-create "*erc-d-client*")) + client-proc) + (with-current-buffer dumb-server-buffer + (erc-d-t-search-for 3 "Starting")) + (setq client-proc (make-network-process + :buffer client-buf + :name "erc-d-client" + :family 'ipv4 + :noquery t + :coding 'binary + :service (process-contact dumb-server :service) + :host "localhost")) + (with-current-buffer dumb-server-buffer + (funcall expect 3 "Connection")) + (process-send-string client-proc "PASS :changeme\r\n") + (sleep-for 0.01) + (process-send-string client-proc "NICK tester\r\n") + (sleep-for 0.01) + (process-send-string client-proc "USER user 0 * :tester\r\n") + (sleep-for 0.01) + (when (process-live-p client-proc) + (process-send-string client-proc "BLAH :too much\r\n") + (sleep-for 0.01)) + (with-current-buffer client-buf + (funcall expect 3 "Welcome to the Internet")) + (erc-d-t-wait-for 2 "dumb-server death" + (not (process-live-p dumb-server))) + (delete-process client-proc) + (when noninteractive + (kill-buffer client-buf) + (kill-buffer dumb-server-buffer)))) + (should (string-match-p "unexpected.*BLAH" (cadr (pop errors)))) + ;; Wouldn't happen IRL + (should (string-match-p "unexpected.*BLAH" (cadr (pop errors)))) + (should-not errors))) + +(defun erc-d-self--dynamic-match-user (_dialog exchange) + "Shared pattern/response handler for canned dynamic DIALOG test." + (should (string= (match-string 1 (erc-d-exchange-request exchange)) + "tester"))) + +(defun erc-d-self--run-dynamic () + "Perform common assertions for \"dynamic\" dialog." + (erc-d-self-with-server (dumb-server erc-server-buffer) dynamic + (with-current-buffer (erc-d-t-wait-for 3 (get-buffer "#chan")) + (erc-d-t-search-for 2 "tester: hey")) + (with-current-buffer erc-server-buffer + (let ((expect (erc-d-t-make-expecter))) + (funcall expect 2 "host is irc.fsf.org") + (funcall expect 2 "modes for tester"))) + (with-current-buffer (process-buffer dumb-server) + (erc-d-t-search-for 2 "irc.fsf.org")) + (when noninteractive + (kill-buffer "#chan")))) + +(ert-deftest erc-d-run-dynamic-default-match () + (let* (dynamic-tally + (erc-d-spec-vars '((user . "user") + (ignored . ((a b) (: a space b))) + (realname . (group (+ graph))))) + (nick (lambda (a) + (push '(nick . match-user) dynamic-tally) + (funcall a :set (funcall a :match 1) 'export))) + (dom (lambda (a) + (push '(dom . match-user) dynamic-tally) + (funcall a :set erc-d-server-fqdn))) + (erc-d-match-handlers + (list :user (lambda (d e) + (erc-d-exchange-rebind d e 'nick nick) + (erc-d-exchange-rebind d e 'dom dom) + (erc-d-self--dynamic-match-user d e)) + :mode-user (lambda (d e) + (erc-d-exchange-rebind d e 'nick "tester") + (erc-d-exchange-rebind d e 'dom dom)))) + (erc-d-server-fqdn "irc.fsf.org")) + (erc-d-self--run-dynamic) + (should (equal '((dom . match-user) (nick . match-user) (dom . match-user)) + dynamic-tally)))) + +(ert-deftest erc-d-run-dynamic-default-match-rebind () + (let* (tally + ;; + (erc-d-spec-vars '((user . "user") + (ignored . ((a b) (: a space b))) + (realname . (group (+ graph))))) + (erc-d-match-handlers + (list :user + (lambda (d e) + (erc-d-exchange-rebind + d e 'nick + (lambda (a) + (push 'bind-nick tally) + (funcall a :rebind 'nick (funcall a :match 1) 'export))) + (erc-d-exchange-rebind + d e 'dom + (lambda () + (push 'bind-dom tally) + (erc-d-exchange-rebind d e 'dom erc-d-server-fqdn))) + (erc-d-self--dynamic-match-user d e)) + :mode-user + (lambda (d e) + (erc-d-exchange-rebind d e 'nick "tester") + (erc-d-exchange-rebind d e 'dom erc-d-server-fqdn)))) + (erc-d-server-fqdn "irc.fsf.org")) + (erc-d-self--run-dynamic) + (should (equal '(bind-nick bind-dom) tally)))) + +(ert-deftest erc-d-run-dynamic-runtime-stub () + (let ((erc-d-spec-vars '((token . (group (or "barnet" "foonet"))))) + (erc-d-match-handlers + (list :pass (lambda (d _e) + (erc-d-load-replacement-dialog d 'dynamic-foonet)))) + (erc-d-self-with-server-password "foonet:changeme")) + (erc-d-self-with-server (_ erc-server-buffer) + (dynamic-stub dynamic-foonet) + (with-current-buffer (erc-d-t-wait-for 3 (get-buffer "#chan")) + (erc-d-t-search-for 2 "alice:") + (erc-d-t-absent-for 0.1 "joe")) + (with-current-buffer erc-server-buffer + (let ((expect (erc-d-t-make-expecter))) + (funcall expect 2 "host is irc.foonet.org") + (funcall expect 2 "NETWORK=FooNet"))) + (when noninteractive + (kill-buffer "#chan"))))) + +(ert-deftest erc-d-run-dynamic-runtime-stub-skip () + (let ((erc-d-spec-vars '((token . "barnet"))) + (erc-d-match-handlers + (list :pass (lambda (d _e) + (erc-d-load-replacement-dialog + d 'dynamic-barnet 1)))) + (erc-d-self-with-server-password "barnet:changeme")) + (erc-d-self-with-server (_ erc-server-buffer) + (dynamic-stub dynamic-barnet) + (with-current-buffer (erc-d-t-wait-for 3 (get-buffer "#chan")) + (erc-d-t-search-for 2 "joe:") + (erc-d-t-absent-for 0.1 "alice")) + (with-current-buffer erc-server-buffer + (let ((expect (erc-d-t-make-expecter))) + (funcall expect 2 "host is irc.barnet.org") + (funcall expect 2 "NETWORK=BarNet"))) + (when noninteractive + (kill-buffer "#chan"))))) + +;; Two servers, in-process, one client per +(ert-deftest erc-d-run-dual-direct () + (let* ((erc-d--slow-mo -1) + (server-a (erc-d-run "localhost" t "erc-d-server-a" 'dynamic-foonet)) + (server-b (erc-d-run "localhost" t "erc-d-server-b" 'dynamic-barnet)) + (server-a-buffer (get-buffer "*erc-d-server-a*")) + (server-b-buffer (get-buffer "*erc-d-server-b*")) + (client-a-buffer (get-buffer-create "*erc-d-client-a*")) + (client-b-buffer (get-buffer-create "*erc-d-client-b*")) + client-a client-b) + (with-current-buffer server-a-buffer (erc-d-t-search-for 4 "Starting")) + (with-current-buffer server-b-buffer (erc-d-t-search-for 4 "Starting")) + (setq client-a (make-network-process + :buffer client-a-buffer + :name "erc-d-client-a" + :family 'ipv4 + :noquery t + :coding 'binary + :service (process-contact server-a :service) + :host "localhost") + client-b (make-network-process + :buffer client-b-buffer + :name "erc-d-client-b" + :family 'ipv4 + :noquery t + :coding 'binary + :service (process-contact server-b :service) + :host "localhost")) + ;; Also tests slo-mo indirectly because FAKE would fail without it + (process-send-string client-a "NICK tester\r\n") + (process-send-string client-b "FAKE noop\r\nNICK tester\r\n") + (sleep-for 0.01) + (process-send-string client-a "USER user 0 * :tester\r\n") + (process-send-string client-b "USER user 0 * :tester\r\n") + (sleep-for 0.01) + (process-send-string client-a "MODE tester +i\r\n") + (process-send-string client-b "MODE tester +i\r\n") + (sleep-for 0.01) + (process-send-string client-a "MODE #chan\r\n") + (process-send-string client-b "MODE #chan\r\n") + (sleep-for 0.01) + (erc-d-t-wait-for 1 "server-a death" (not (process-live-p server-a))) + (erc-d-t-wait-for 1 "server-b death" (not (process-live-p server-b))) + (when noninteractive + (kill-buffer client-a-buffer) + (kill-buffer client-b-buffer) + (kill-buffer server-a-buffer) + (kill-buffer server-b-buffer)))) + +;; This can be removed; only exists to get a baseline for next test +(ert-deftest erc-d-run-fuzzy-direct () + (let* ((erc-d-spec-vars + `((now . ,(lambda () (format-time-string "%FT%T.%3NZ" nil t))))) + (dumb-server (erc-d-run "localhost" t 'fuzzy)) + (dumb-server-buffer (get-buffer "*erc-d-server*")) + (client-buffer (get-buffer-create "*erc-d-client*")) + client) + (with-current-buffer "*erc-d-server*" (erc-d-t-search-for 4 "Starting")) + (setq client (make-network-process + :buffer client-buffer + :name "erc-d-client" + :family 'ipv4 + :noquery t + :coding 'binary + :service (process-contact dumb-server :service) + :host "localhost")) + ;; We could also just send this as a single fatty + (process-send-string client "PASS :changeme\r\n") + (sleep-for 0.01) + (process-send-string client "NICK tester\r\n") + (sleep-for 0.01) + (process-send-string client "USER user 0 * :tester\r\n") + (sleep-for 0.01) + (process-send-string client "MODE tester +i\r\n") + (sleep-for 0.01) + (process-send-string client "JOIN #bar\r\n") + (sleep-for 0.01) + (process-send-string client "JOIN #foo\r\n") + (sleep-for 0.01) + (process-send-string client "MODE #bar\r\n") + (sleep-for 0.01) + (process-send-string client "MODE #foo\r\n") + (sleep-for 0.01) + (erc-d-t-wait-for 1 "dumb-server death" + (not (process-live-p dumb-server))) + (when noninteractive + (kill-buffer client-buffer) + (kill-buffer dumb-server-buffer)))) + +;; Without adjusting penalty, takes ~15 secs. With is comprable to direct ^. +(ert-deftest erc-d-run-fuzzy () + (let ((erc-server-flood-penalty 1.2) ; penalty < margin/sends is basically 0 + (erc-d-linger-secs 0.1) + (erc-d-spec-vars + `((now . ,(lambda () (format-time-string "%FT%T.%3NZ" nil t))))) + erc-server-auto-reconnect) + (erc-d-self-with-server (_ erc-server-buffer) fuzzy + (with-current-buffer erc-server-buffer + (erc-d-t-search-for 2 "away") + (goto-char erc-input-marker) + (erc-cmd-JOIN "#bar")) + (erc-d-t-wait-for 2 (get-buffer "#bar")) + (with-current-buffer erc-server-buffer + (erc-cmd-JOIN "#foo")) + (erc-d-t-wait-for 20 (get-buffer "#foo")) + (with-current-buffer "#bar" + (erc-d-t-search-for 1 "was created on")) + (with-current-buffer "#foo" + (erc-d-t-search-for 5 "was created on"))))) + +(ert-deftest erc-d-run-no-block () + (let ((erc-server-flood-penalty 1) + (erc-d-linger-secs 1.2) + (expect (erc-d-t-make-expecter)) + erc-server-auto-reconnect) + (erc-d-self-with-server (_ erc-server-buffer) no-block + (with-current-buffer erc-server-buffer + (funcall expect 2 "away") + (funcall expect 1 erc-prompt) + (with-current-buffer erc-server-buffer (erc-cmd-JOIN "#foo"))) + (with-current-buffer (erc-d-t-wait-for 2 (get-buffer "#foo")) + (funcall expect 2 "was created on")) + + (ert-info ("Join #bar") + (with-current-buffer erc-server-buffer (erc-cmd-JOIN "#bar")) + (erc-d-t-wait-for 2 (get-buffer "#bar"))) + + (with-current-buffer "#bar" (funcall expect 1 "was created on")) + + (ert-info ("Server expects next pattern but keeps sending") + (with-current-buffer "#foo" (funcall expect 2 "Rosalind")) + (with-current-buffer "#bar" (funcall expect 1 "hi")) + (with-current-buffer "#foo" + (should-not (search-forward " I am heard" nil t)) + (funcall expect 1.5 " I am heard")))))) + +(defun erc-d-self--run-proxy-direct (dumb-server dumb-server-buffer port) + "Start DUMB-SERVER with DUMB-SERVER-BUFFER and PORT. +These are steps shared by in-proc and subproc variants testing a +bouncer-like setup." + (when (version< emacs-version "28") (ert-skip "TODO connection refused")) + (let ((client-buffer-foo (get-buffer-create "*erc-d-client-foo*")) + (client-buffer-bar (get-buffer-create "*erc-d-client-bar*")) + (expect (erc-d-t-make-expecter)) + client-foo + client-bar) + (setq client-foo (make-network-process + :buffer client-buffer-foo + :name "erc-d-client-foo" + :family 'ipv4 + :noquery t + :coding 'binary + :service port + :host "localhost") + client-bar (make-network-process + :buffer client-buffer-bar + :name "erc-d-client-bar" + :family 'ipv4 + :noquery t + :coding 'binary + :service port + :host "localhost")) + (with-current-buffer dumb-server-buffer + (funcall expect 3 "Connection")) + (process-send-string client-foo "PASS :foo:changeme\r\n") + (process-send-string client-bar "PASS :bar:changeme\r\n") + (sleep-for 0.01) + (process-send-string client-foo "NICK tester\r\n") + (process-send-string client-bar "NICK tester\r\n") + (sleep-for 0.01) + (process-send-string client-foo "USER user 0 * :tester\r\n") + (process-send-string client-bar "USER user 0 * :tester\r\n") + (sleep-for 0.01) + (process-send-string client-foo "MODE tester +i\r\n") + (process-send-string client-bar "MODE tester +i\r\n") + (sleep-for 0.01) + (with-current-buffer client-buffer-foo + (funcall expect 3 "FooNet") + (funcall expect 3 "irc.foo.net") + (funcall expect 3 "marked as being away") + (goto-char (point-min)) + (should-not (search-forward "bar" nil t))) + (with-current-buffer client-buffer-bar + (funcall expect 3 "BarNet") + (funcall expect 3 "irc.bar.net") + (funcall expect 3 "marked as being away") + (goto-char (point-min)) + (should-not (search-forward "foo" nil t))) + (erc-d-t-wait-for 2 "dumb-server death" + (not (process-live-p dumb-server))) + (delete-process client-foo) + (delete-process client-bar) + (when noninteractive + (kill-buffer client-buffer-foo) + (kill-buffer client-buffer-bar) + (kill-buffer dumb-server-buffer)))) + +;; This test shows the simplest way to set up template variables: put +;; everything needed for the whole session in `erc-d-spec-vars' before +;; starting the server. + +(ert-deftest erc-d-run-proxy-direct-spec-vars () + (let* ((dumb-server-buffer (get-buffer-create "*erc-d-server*")) + (erc-d-linger-secs 0.5) + (erc-d-spec-vars + `((network . (group (+ alpha))) + (fqdn . ,(lambda (a) + (let ((network (funcall a :match 1 'pass))) + (should (member network '("foo" "bar"))) + (funcall a :set (concat "irc." network ".net"))))) + (net . ,(lambda (a) + (let ((network (funcall a :match 1 'pass))) + (should (member network '("foo" "bar"))) + (concat (capitalize network) "Net")))))) + (dumb-server (erc-d-run "localhost" t 'proxy-foonet 'proxy-barnet)) + (port (process-contact dumb-server :service))) + (with-current-buffer dumb-server-buffer + (erc-d-t-search-for 3 "Starting")) + (erc-d-self--run-proxy-direct dumb-server dumb-server-buffer port))) + +(cl-defun erc-d-self--start-server (&key dialogs buffer linger program libs) + "Start and return a server in a subprocess using BUFFER and PORT. +DIALOGS are symbols representing the base names of dialog files in +`erc-d-u-canned-dialog-dir'. LIBS are extra files to load." + (push (locate-library "erc-d" nil (list erc-d-u--library-directory)) libs) + (cl-assert (car libs)) + (let* ((args `("erc-d-server" ,buffer + ,(concat invocation-directory invocation-name) + "-Q" "-batch" "-L" ,erc-d-u--library-directory + ,@(let (o) (while libs (push (pop libs) o) (push "-l" o)) o) + "-eval" ,(format "%S" program) "-f" "erc-d-serve" + ,@(when linger (list "--linger" (number-to-string linger))) + ,@(mapcar #'erc-d-u--expand-dialog-symbol dialogs))) + (proc (apply #'start-process args))) + (set-process-query-on-exit-flag proc nil) + (with-current-buffer buffer + (erc-d-t-search-for 5 "Starting") + (search-forward " (") + (backward-char)) + (let ((pair (read buffer))) + (cons proc (cdr pair))))) + +(ert-deftest erc-d-run-proxy-direct-subprocess () + (let* ((buffer (get-buffer-create "*erc-d-server*")) + ;; These are quoted because they're passed as printed forms to subproc + (fqdn '(lambda (a e) + (let* ((d (erc-d-exchange-dialog e)) + (name (erc-d-dialog-name d))) + (funcall a :set (if (eq name 'proxy-foonet) + "irc.foo.net" + "irc.bar.net"))))) + (net '(lambda (a) + (funcall a :rebind 'net + (if (eq (funcall a :dialog-name) 'proxy-foonet) + "FooNet" + "BarNet")))) + (program `(setq erc-d-spec-vars '((fqdn . ,fqdn) + (net . ,net) + (network . (group (+ alpha)))))) + (port (erc-d-self--start-server + :linger 0.3 + :program program + :buffer buffer + :dialogs '(proxy-foonet proxy-barnet))) + (server (pop port))) + (erc-d-self--run-proxy-direct server buffer port))) + +(ert-deftest erc-d-run-proxy-direct-subprocess-lib () + (let* ((buffer (get-buffer-create "*erc-d-server*")) + (lib (ert-resource-file "proxy-subprocess.el")) + (port (erc-d-self--start-server :linger 0.3 + :buffer buffer + :dialogs '(proxy-foonet proxy-barnet) + :libs (list lib))) + (server (pop port))) + (erc-d-self--run-proxy-direct server buffer port))) + +(ert-deftest erc-d-run-no-pong () + (let* (erc-d-auto-pong + ;; + (erc-d-spec-vars + `((nonce . (group (: digit digit))) + (echo . ,(lambda (a) + (should (string= (funcall a :match 1) "42")) "42")))) + (dumb-server-buffer (get-buffer-create "*erc-d-server*")) + (dumb-server (erc-d-run "localhost" t 'no-pong)) + (expect (erc-d-t-make-expecter)) + (client-buf (get-buffer-create "*erc-d-client*")) + client-proc) + (with-current-buffer dumb-server-buffer + (erc-d-t-search-for 3 "Starting")) + (setq client-proc (make-network-process + :buffer client-buf + :name "erc-d-client" + :family 'ipv4 + :noquery t + :coding 'binary + :service (process-contact dumb-server :service) + :host "localhost")) + (with-current-buffer dumb-server-buffer + (funcall expect 3 "Connection")) + (process-send-string client-proc "PASS :changeme\r\nNICK tester\r\n") + (sleep-for 0.01) + (process-send-string client-proc "USER user 0 * :tester\r\n") + (sleep-for 0.01) + (process-send-string client-proc "MODE tester +i\r\n") + (sleep-for 0.01) + (with-current-buffer client-buf + (funcall expect 3 "ExampleOrg") + (funcall expect 3 "irc.example.org") + (funcall expect 3 "marked as being away")) + (ert-info ("PING is not intercepted by specialized method") + (process-send-string client-proc "PING 42\r\n") + (with-current-buffer client-buf + (funcall expect 3 "PONG"))) + (erc-d-t-wait-for 2 "dumb-server death" + (not (process-live-p dumb-server))) + (delete-process client-proc) + (when noninteractive + (kill-buffer client-buf) + (kill-buffer dumb-server-buffer)))) + +;; Inspect replies as they arrive within a single exchange, i.e., ensure we +;; don't regress to prior buggy version in which inspection wasn't possible +;; until all replies had been sent by the server. +(ert-deftest erc-d-run-incremental () + (let ((erc-server-flood-penalty 0) + (expect (erc-d-t-make-expecter)) + erc-d-linger-secs) + (erc-d-self-with-server (_ erc-server-buffer) incremental + (with-current-buffer erc-server-buffer + (funcall expect 3 "marked as being away")) + (with-current-buffer erc-server-buffer + (erc-cmd-JOIN "#foo")) + (with-current-buffer (erc-d-t-wait-for 1 (get-buffer "#foo")) + (funcall expect 1 "Users on #foo") + (funcall expect 1 "Look for me") + (not (search-forward "Done" nil t)) + (funcall expect 10 "Done") + (erc-send-message "Hi"))))) + +(ert-deftest erc-d-unix-socket-direct () + (skip-unless (featurep 'make-network-process '(:family local))) + (let* ((erc-d-linger-secs 0.1) + (sock (expand-file-name "erc-d.sock" temporary-file-directory)) + (dumb-server (erc-d-run nil sock 'basic)) + (dumb-server-buffer (get-buffer "*erc-d-server*")) + (client-buffer (get-buffer-create "*erc-d-client*")) + client) + (with-current-buffer "*erc-d-server*" + (erc-d-t-search-for 4 "Starting")) + (unwind-protect + (progn + (setq client (make-network-process + :buffer client-buffer + :name "erc-d-client" + :family 'local + :noquery t + :coding 'binary + :service sock)) + (process-send-string client "PASS :changeme\r\n") + (sleep-for 0.01) + (process-send-string client "NICK tester\r\n") + (sleep-for 0.01) + (process-send-string client "USER user 0 * :tester\r\n") + (sleep-for 0.1) + (process-send-string client "MODE tester +i\r\n") + (sleep-for 0.01) + (process-send-string client "MODE #chan\r\n") + (sleep-for 0.01) + (erc-d-t-wait-for 1 "dumb-server death" + (not (process-live-p dumb-server))) + (when noninteractive + (kill-buffer client-buffer) + (kill-buffer dumb-server-buffer))) + (delete-file sock)))) + +;;; erc-d-self.el ends here diff --git a/test/lisp/erc/erc-d/erc-d-t.el b/test/lisp/erc/erc-d/erc-d-t.el new file mode 100644 index 0000000000..97231a3755 --- /dev/null +++ b/test/lisp/erc/erc-d/erc-d-t.el @@ -0,0 +1,169 @@ +;;; erc-d-t.el --- ERT helpers for ERC test server -*- lexical-binding: t -*- + +;; Copyright (C) 2020-2021 Free Software Foundation, Inc. +;; +;; This file is part of GNU Emacs. +;; +;; This program is free software: you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see +;; . + +;;; Commentary: + +;;; Code: +(eval-and-compile (let ((dir (getenv "EMACS_TEST_DIRECTORY"))) + (when dir + (load (concat dir "/lisp/erc/erc-d/erc-d-u") nil t)))) +(require 'erc-d-u) +(require 'ert) + +(defun erc-d-t-kill-related-buffers () + "Kill all erc- or erc-d- related buffers." + (let (buflist) + (dolist (buf (buffer-list)) + (with-current-buffer buf + (when (or erc-d-u--process-buffer + (derived-mode-p 'erc-mode)) + (push buf buflist)))) + (dolist (buf buflist) + (when (and (boundp 'erc-server-flood-timer) + (timerp erc-server-flood-timer)) + (cancel-timer erc-server-flood-timer)) + (when-let ((proc (get-buffer-process buf))) + (delete-process proc)) + (when (buffer-live-p buf) + (kill-buffer buf)))) + (while (when-let ((buf (pop erc-d-u--canned-buffers))) + (kill-buffer buf)))) + +(defun erc-d-t-silence-around (orig &rest args) + "Run ORIG function with ARGS silently. +Use this on `erc-handle-login' and `erc-server-connect'." + (let ((inhibit-message t)) + (apply orig args))) + +(defvar erc-d-t-cleanup-sleep-secs 0.1) + +(defmacro erc-d-t-with-cleanup (bindings cleanup &rest body) + "Execute BODY and run CLEANUP form regardless of outcome. +`let*'-bind BINDINGS and make them available in BODY and CLEANUP. +After CLEANUP, destroy any values in BINDINGS that remain bound to +buffers or processes. Sleep `erc-d-t-cleanup-sleep-secs' before +returning." + (declare (indent 2)) + `(let* ,bindings + (unwind-protect + (progn ,@body) + ,cleanup + (when noninteractive + (let (bufs procs) + (dolist (o (list ,@(mapcar (lambda (b) (or (car-safe b) b)) + bindings))) + (when (bufferp o) + (push o bufs)) + (when (processp o) + (push o procs))) + (dolist (proc procs) + (delete-process proc) + (when-let ((buf (process-buffer proc))) + (push buf bufs))) + (dolist (buf bufs) + (when-let ((proc (get-buffer-process buf))) + (delete-process proc)) + (when (bufferp buf) + (ignore-errors (kill-buffer buf))))) + (sleep-for erc-d-t-cleanup-sleep-secs))))) + +(defmacro erc-d-t-wait-for (max-secs msg &rest body) + "Wait for BODY to become non-nil. +Or signal error with MSG after MAX-SECS. When MAX-SECS is negative, +signal if BODY is ever non-nil before MAX-SECS elapses. On success, +return BODY's value. + +Note: this assumes BODY is waiting on a peer's output. It tends to +artificially accelerate consumption of all process output, which may not +be desirable." + (declare (indent 2)) + (unless (or (stringp msg) (memq (car-safe msg) '(format concat))) + (push msg body) + (setq msg (prin1-to-string body))) + (let ((inverted (make-symbol "inverted")) + (time-out (make-symbol "time-out")) + (result (make-symbol "result"))) + `(ert-info ((concat "Awaiting: " ,msg)) + (let ((,time-out (abs ,max-secs)) + (,inverted (< ,max-secs 0)) + (,result ',result)) + (with-timeout (,time-out (if ,inverted + (setq ,inverted nil) + (error "Failed awaiting: %s" ,msg))) + (while (not (setq ,result (progn ,@body))) + (when (and (accept-process-output nil 0.1) (not noninteractive)) + (redisplay)))) + (when ,inverted + (error "Failed awaiting: %s" ,msg)) + ,result)))) + +(defmacro erc-d-t-ensure-for (max-secs msg &rest body) + "Ensure BODY remains non-nil for MAX-SECS. +On failure, emit MSG." + (declare (indent 2)) + (unless (or (stringp msg) (memq (car-safe msg) '(format concat))) + (push msg body) + (setq msg (prin1-to-string body))) + `(erc-d-t-wait-for (- (abs ,max-secs)) ,msg (not (progn ,@body)))) + +(defun erc-d-t-search-for (timeout text &optional from on-success) + "Wait for TEXT to appear in current buffer before TIMEOUT secs. +With marker or number FROM, only consider the portion of the buffer from +that point forward. If TEXT is a cons, interpret it as an RX regular +expression. If ON-SUCCESS is a function, call it when TEXT is found." + (save-restriction + (widen) + (let* ((rxp (consp text)) + (fun (if rxp #'search-forward-regexp #'search-forward)) + (pat (if rxp (rx-to-string text) text)) + res) + (erc-d-t-wait-for timeout (format "string: %s" text) + (goto-char (or from (point-min))) + (setq res (funcall fun pat nil t)) + (if (and on-success res) + (funcall on-success) + res))))) + +(defun erc-d-t-absent-for (timeout text &optional from on-success) + "Assert TEXT doesn't appear in current buffer for TIMEOUT secs." + (erc-d-t-search-for (- (abs timeout)) text from on-success)) + +(defun erc-d-t-make-expecter () + "Return function to search for new output in buffer. +Assume new text is only inserted at or after `erc-insert-marker'. + +The returned function works like `erc-d-t-search-for', but it never +revisits previously covered territory, and the optional fourth argument, +ON-SUCCESS, is nonexistent. To reset, specify a FROM argument." + (let (positions) + (lambda (timeout text &optional reset-from) + (let* ((pos (cdr (assq (current-buffer) positions))) + (cb (lambda () + (unless pos + (push (cons (current-buffer) (setq pos (make-marker))) + positions)) + (marker-position + (set-marker pos (min (point) (1- (point-max)))))))) + (when reset-from + (set-marker pos reset-from)) + (erc-d-t-search-for timeout text pos cb))))) + +(provide 'erc-d-t) +;;; erc-d-t.el ends here diff --git a/test/lisp/erc/erc-d/erc-d-u.el b/test/lisp/erc/erc-d/erc-d-u.el new file mode 100644 index 0000000000..187ee272d1 --- /dev/null +++ b/test/lisp/erc/erc-d/erc-d-u.el @@ -0,0 +1,203 @@ +;;; erc-d-u.el --- Helpers for ERC test server -*- lexical-binding: t -*- + +;; Copyright (C) 2020-2021 Free Software Foundation, Inc. +;; +;; This file is part of GNU Emacs. +;; +;; This program is free software: you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see +;; . + +;;; Commentary: + +;; The utilities here are kept separate from those in `erc-d' so that +;; tests running the server in a subprocess can use them without +;; having to require the main lib. If migrating outside of test/lisp, +;; there may be no reason to continue this. +;; +;; Another (perhaps misguided) goal here is to avoid having ERC itself +;; as a dependency. +;; +;; FIXME this ^ is no longer the case (ERC is not a dependency) + +;;; Code: +(require 'rx) +(require 'subr-x) +(eval-when-compile (require 'ert)) + +(defvar erc-d-u--canned-buffers nil + "List of canned dialog buffers currently open for reading.") + +(cl-defstruct (erc-d-u-scan-d) ; dialog scanner + (buf nil :type buffer) + (done nil :type boolean) + (last nil :type integer) + (hunks nil :type (list-of marker)) + (f #'erc-d-u--read-exchange-default :type function)) + +(cl-defstruct (erc-d-u-scan-e) ; exchange scanner + (sd nil :type erc-d-u-scan-d) + (pos nil :type marker)) + +(defun erc-d-u--read-dialog (info) + "Read dialog file and stash relevant state in `erc-d-u-scan-d' INFO." + (if (and (buffer-live-p (erc-d-u-scan-d-buf info)) + (with-current-buffer (erc-d-u-scan-d-buf info) + (condition-case _err + (progn + (when (erc-d-u-scan-d-last info) + (goto-char (erc-d-u-scan-d-last info)) + (forward-list)) + (setf (erc-d-u-scan-d-last info) (point)) + (down-list) + (push (set-marker (make-marker) (point)) + (erc-d-u-scan-d-hunks info))) + ((end-of-buffer scan-error) + (setf (erc-d-u-scan-d-done info) t) + nil)))) + (make-erc-d-u-scan-e :sd info :pos (car (erc-d-u-scan-d-hunks info))) + (unless (erc-d-u-scan-d-hunks info) + (kill-buffer (erc-d-u-scan-d-buf info)) + nil))) + +(defun erc-d-u--read-exchange-default (info) + "Read from marker in exchange `erc-d-u-scan-e' object INFO." + (let ((hunks (erc-d-u-scan-e-sd info)) + (pos (erc-d-u-scan-e-pos info))) + (or (and (erc-d-u-scan-d-hunks hunks) + (with-current-buffer (erc-d-u-scan-d-buf hunks) + (goto-char pos) + (condition-case _err + (read pos) + ;; Raised unless malformed + (invalid-read-syntax + nil)))) + (unless (or (cl-callf (lambda (s) (delq pos s)) ; flip + (erc-d-u-scan-d-hunks hunks)) + (not (erc-d-u-scan-d-done hunks))) + (kill-buffer (erc-d-u-scan-d-buf hunks)) + nil)))) + +(defun erc-d-u--read-exchange (info) + "Call exchange reader assigned in `erc-d-u-scan-e' object INFO." + (funcall (erc-d-u-scan-d-f (erc-d-u-scan-e-sd info)) info)) + +(defun erc-d-u--canned-read (file) + "Dispense a reader for each exchange in dialog FILE." + (let ((buf (generate-new-buffer (file-name-nondirectory file)))) + (push buf erc-d-u--canned-buffers) + (with-current-buffer buf + (setq-local parse-sexp-ignore-comments t + coding-system-for-read 'utf-8) + (add-hook 'kill-buffer-hook + (lambda () (setq erc-d-u--canned-buffers + (delq buf erc-d-u--canned-buffers))) + nil 'local) + (insert-file-contents-literally file) + (lisp-data-mode)) + (make-erc-d-u-scan-d :buf buf))) + +(defvar erc-d-u--library-directory (file-name-directory load-file-name)) +(defvar erc-d-u-canned-dialog-dir + (file-name-as-directory (expand-file-name "erc-d-self-resources" + erc-d-u--library-directory))) + +(defun erc-d-u--normalize-canned-name (dialog) + "Return DIALOG name as a symbol without validating it." + (if (symbolp dialog) + dialog + (intern (file-name-base dialog)))) + +(defvar erc-d-u-canned-file-name-extension ".eld") + +(defun erc-d-u--expand-dialog-symbol (dialog) + "Return filename based on symbol DIALOG." + (let ((name (symbol-name dialog))) + (unless (equal (file-name-extension name) + erc-d-u-canned-file-name-extension) + (setq name (concat name erc-d-u-canned-file-name-extension))) + (expand-file-name name erc-d-u-canned-dialog-dir))) + +(defun erc-d-u--massage-canned-name (dialog) + "Return DIALOG in a form acceptable to `erc-d-run'." + (if (or (symbolp dialog) (file-exists-p dialog)) + dialog + (erc-d-u--expand-dialog-symbol (intern dialog)))) + +(defun erc-d-u--canned-load-dialog (dialog) + "Load dispensing exchanges from DIALOG. +If DIALOG is a string, consider it a filename. Otherwise find a file +in `erc-d-u-canned-dialog-dir' with a base name matching the symbol's +name. + +Return an iterator that yields exchanges, each one an iterator of spec +forms. The first is a so-called request spec and the rest are composed +of zero or more response specs." + (when (symbolp dialog) + (setq dialog (erc-d-u--expand-dialog-symbol dialog))) + (unless (file-exists-p dialog) + (error "File not found: %s" dialog)) + (erc-d-u--canned-read dialog)) + +(defun erc-d-u--read-exchange-slowly (num orig info) + (when-let ((spec (funcall orig info))) + (when (symbolp (car spec)) + (setf (nth 1 spec) (cond ((functionp num) + (funcall num (nth 1 spec))) + ((< num 0) + (max (nth 1 spec) (- num))) + (t (+ (nth 1 spec) num))))) + spec)) + +(defun erc-d-u--rewrite-for-slow-mo (num read-info) + "Return READ-INFO with a modified reader. +When NUM is a positive number, delay incoming requests by NUM more +seconds. If NUM is negative, raise insufficient incoming delays to at +least -NUM seconds. If NUM is a function, set each delay to whatever it +returns when called with the existing value." + (let ((orig (erc-d-u-scan-d-f read-info))) + (setf (erc-d-u-scan-d-f read-info) + (apply-partially #'erc-d-u--read-exchange-slowly num orig)) + read-info)) + +(defun erc-d-u--get-remote-port (process) + "Return peer TCP port for client PROCESS. +When absent, just generate an id." + (let ((remote (plist-get (process-contact process t) :remote))) + (if (vectorp remote) + (aref remote (1- (length remote))) + (format "%s:%d" (process-contact process :local) + (logand 1023 (time-convert nil 'integer)))))) + +(defun erc-d-u--format-bind-address (process) + "Return string or (STRING . INT) for bind address of network PROCESS." + (let ((local (process-contact process :local))) + (if (vectorp local) ; inet + (cons (mapconcat #'number-to-string (seq-subseq local 0 -1) ".") + (aref local (1- (length local)))) + local))) + +(defun erc-d-u--unkeyword (plist) + "Return a copy of PLIST with keywords keys converted to non-keywords." + (cl-loop for (key value) on plist by #'cddr + when (keywordp key) + do (setq key (intern (substring (symbol-name key) 1))) + append (list key value))) + +(defvar-local erc-d-u--process-buffer nil + "Beacon for erc-d process buffers. +The server process is usually deleted first, but we may want to examine +the buffer afterward.") + +(provide 'erc-d-u) +;;; erc-d-u.el ends here diff --git a/test/lisp/erc/erc-d/erc-d.el b/test/lisp/erc/erc-d/erc-d.el new file mode 100644 index 0000000000..9aca27d922 --- /dev/null +++ b/test/lisp/erc/erc-d/erc-d.el @@ -0,0 +1,996 @@ +;;; erc-d.el --- A dumb test server for ERC -*- lexical-binding: t -*- + +;; Copyright (C) 2020-2021 Free Software Foundation, Inc. +;; +;; Version: 1.1 +;; FIXME reset^ to 1.0 or delete if adding to Emacs +;; +;; This file is part of GNU Emacs. +;; +;; This program is free software: you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see +;; . + +;;; Commentary: + +;; This is a netcat style server for testing ERC. The "d" in the name +;; stands for "daemon" as well as for "dialog" (as well as for "dumb" +;; because this server isn't very smart). It either spits out a +;; canned reply when an incoming request matches the expected regexp +;; or signals an error and dies. The entry point function is +;; `erc-d-run'. +;; +;; Canned scripts, or "dialogs," should be Lisp-Data files containing +;; one or more request/reply forms like this: +;; +;; | ((mode-chan 1.5 "MODE #chan") ; request: tag, expr, regex +;; | (0.1 ":irc.org 324 bob #chan +Cint") ; reply: delay, content +;; | (0.0 ":irc.org 329 bob #chan 12345")) ; reply: ... +;; +;; These are referred to as "exchanges." The first element is a list +;; whose CAR is a descriptive "tag" and whose CDR is an incoming +;; "spec" representing an inbound message from the client. The rest +;; of the exchange is composed of outgoing specs representing +;; server-to-client messages. A tag can be any symbol (ideally unique +;; in the dialog), but a leading tilde means the request should be +;; allowed to arrive out of order (within the allotted time). +;; +;; The first element in an incoming spec is a number indicating the +;; maximum number of seconds to wait for a match before raising an +;; error. The CDR is interpreted as the collective arguments of an +;; `rx' form to be matched against the raw request (stripped of its +;; CRLF line ending). A "string-start" backslash assertion, "\\`", is +;; prepended to all patterns. +;; +;; Similarly, the leading number in an *outgoing* spec indicates how +;; many seconds to wait before sending the line, which is rendered by +;; concatenating the other members after evaluating each in place. +;; CRLF line endings are appended on the way out and should be absent. +;; +;; Recall that IRC is "asynchronous," meaning some flow intervals +;; don't jibe with lockstep request-reply semantics. However, for our +;; purposes, grouping things as [input, output1, ..., outputN] makes +;; sense, even though input and output may be completely unrelated. +;; +;; Template interpolation: +;; +;; A rudimentary templating facility is provided for additional +;; flexibility. However, it's best to keep things simple (even if +;; overly verbose), so others can easily tell what's going on at a +;; glance. If necessary, consult existing tests for examples (grep +;; for the variables `erc-d-spec-vars' and `erc-d-match-handlers'). +;; +;; Subprocess or in-process?: +;; +;; Running in-process confers better visibility and easier setup at +;; the cost of additional cleanup and resource wrangling. With a +;; subprocess, cleanup happens by pulling the plug, but configuration +;; means loading a separate file or passing -eval "(forms...)" during +;; invocation. In some cases, a subprocess may be the only option, +;; like when trying to avoid `require'ing this file. +;; +;; Dialog objects: +;; +;; For a given exchange, the first argument passed to a request +;; handler is the `erc-d-dialog' object representing the overall +;; conversation with the connecting peer. It can be used to pass +;; information between handlers during a session. Some important +;; items are: +;; +;; * name (symbol); name of the current dialog +;; +;; * queue (ring); a backlog of unhandled raw requests, minus CRLF +;; endings. +;; +;; * timers (list of timers); when run, these send messages originally +;; deferred as per the most recently matched exchange's delay info. +;; Normally, all outgoing messages must be sent before another request +;; is considered. (See `erc-d--send-outgoing' for an escape hatch.) +;; +;; * hunks (iterator of iterators); unconsumed exchanges as read from +;; a Lisp-Data dialog file. The exchange iterators being dispensed +;; themselves yield portions of member forms as a 2- or 3-part +;; sequence: [tag] spec. (Here, "hunk" just means "list of raw, +;; unrendered exchange elements") +;; +;; * vars (alist of cons pairs); for sharing state among template +;; functions during the lifetime of an exchange. Initially populated +;; by `erc-d-spec-vars', these KEY/VALUE pairs are made available in +;; the template environment as bound variables. Updates can be made +;; by exchange handlers (see `erc-d-match-handlers'). When VALUE is a +;; function, occurrences of KEY in an outgoing spec are replaced with +;; the result of calling VALUE with match data set appropriately. See +;; `erc-d--render-entries' for details. +;; +;; * exchanges (ring of erc-d-exchange objects); activated hunks +;; allowed to match out of order, plus the current active exchange +;; being yielded from, if any. See `erc-d-exchange'. +;; +;; TODO +;; +;; - Remove un(der)used functionality and simplify API +;; - Maybe migrate d-u and d-i dependencies here + +;;; Code: +(eval-and-compile (let ((dir (getenv "EMACS_TEST_DIRECTORY"))) + (when dir + (load (concat dir "/lisp/erc/erc-d/erc-d-i") nil t) + (load (concat dir "/lisp/erc/erc-d/erc-d-u") nil t)))) +(require 'ring) +(require 'erc-d-i) +(require 'erc-d-u) + +(defvar erc-d-server-name "erc-d-server" + "Default name of a server process and basis for its buffer name. +Only relevant when starting a server with `erc-d-run'.") + +(defvar erc-d-server-fqdn "irc.example.org" + "Usually the same as the server's RPL_MYINFO \"announced name\". +Possibly used by overriding handlers, like the one for PING, and/or +dialog templates for the sender portion of a reply message.") + +(defvar erc-d-linger-secs nil + "Seconds to wait before quitting for all dialogs. +For more granular control, use the provided LINGER `rx' variable (alone) +as the incoming template spec of a dialog's last exchange.") + +(defvar erc-d-spec-vars nil + "An alist of template bindings available to client dialogs. +Populate it when calling `erc-d-run', and the contents will be made +available to all client dialogs through the `erc-d-dialog' \"vars\" +field and (therefore) to all templates as variables when rendering. For +example, a key/value pair like (network . \"oftc\") will cause instances +of the (unquoted) symbol `network' to be replaced with \"oftc\" in the +rendered template string. + +This list provides default template bindings common to all dialogs. +Each new client-connection process makes a shallow copy on init, but the +usual precautions apply when mutating member items. Within the span of +a dialog, updates not applicable to all exchanges should die with their +exchange. See `erc-d--render-entries' for details. In the unlikely +event that an exchange-specific handler is needed, see +`erc-d-match-handlers'.") + +(defvar erc-d-match-handlers nil + "A plist of exchange-tag symbols mapped to request-handler functions. +This is meant to address edge cases for which `erc-d-spec-vars' comes up +short. These may include (1) needing access to the client process +itself and/or (2) adding or altering outgoing response templates before +rendering. Note that (2) requires using `erc-d-exchange-rebind' instead +of manipulating exchange bindings directly. + +The hook-like function `erc-d-on-match' calls any handler whose key is +`eq' to the tag of the currently matched exchange (passing the client +`erc-d-dialog' as the first argument and the current `erc-d-exchange' +object as the second). The handler runs just prior to sending the first +response.") + +(defvar erc-d-auto-pong t + "Handle PING requests automatically.") + +(defvar erc-d--in-process t + "Whether the server is running in the same Emacs as ERT.") + +(defvar erc-d--slow-mo nil + "Adjustment for all incoming timeouts. +This is to allow for human interaction or a slow Emacs or CI runner. +The value is the number of seconds to extend all incoming spec timeouts +by on init. If the value is a negative number, it's negated and +interpreted as a lower bound to raise all incoming timeouts to. If the +value is a function, it should take an existing timeout in seconds and +return a replacement.") + +(defconst erc-d--eof-sentinel "__EOF__") +(defconst erc-d--linger-sentinel "__LINGER__") +(defconst erc-d--drop-sentinel "__DROP__") + +(defvar erc-d--clients nil + "List containing all clients for this server session.") + +;; Some :type names may just be made up (not actual CL types) + +(cl-defstruct (erc-d-spec) ; see `erc-d--render-entries' + (head nil :type symbol) + (entry nil :type list) + (state 0 :type integer)) + +(cl-defstruct (erc-d-exchange) + "Object representing a request/response unit from a canned dialog." + (dialog nil :type erc-d-dialog) ; owning dialog + (tag nil :type symbol) ; a.k.a. tag, the caar + (pattern nil :type string) ; regexp to match requests against + (inspec nil :type list) ; original unrendered incoming spec + (hunk nil :type erc-d-u-scan-e) ; active raw exchange hunk being yielded + (spec nil :type erc-d-spec) ; active spec, see `erc-d--render-entries' + (timeout nil :type number) ; time allotted for current request + (timer nil :type timer) ; match timer fires when timeout expires + (bindings nil :type list) ; `eval'-style env pairs (KEY . VAL) ... + (rx-bindings nil :type list) ; rx-let bindings + (labels nil :type list) ; let-style bindings (KEY VAL) ... + (deferred nil :type boolean) ; whether sender is paused + ;; Post-match + (match-data nil :type match-data) ; from the latest matched request + (request nil :type string)) ; the original request sans CRLF + +(cl-defstruct (erc-d-dialog) + "Session state for managing a client conversation." + (process nil :type process) ; client-connection process + (name nil :type symbol) ; likely the interned stem of the file + (queue nil :type ring) ; backlog of incoming lines to process + (hunks nil :type erc-d-u-scan-d) ; nil when done; info on raw exchange hunks + (timers nil :type list) ; unsent replies + (vars nil :type list) ; template bindings for rendering + (exchanges nil :type ring) ; ring of erc-d-exchange objects + (state nil :type symbol) ; handler's last recorded control state + (matched nil :type erc-d-exchange) ; currently matched exchange + (message nil :type erc-d-i-message) ; `erc-d-i-message' + (match-handlers nil :type list) ; copy of `erc-d-match-handlers' + (server-fqdn nil :type string) ; copy of `erc-d-server-fqdn' + (finalizer nil :type function) ; custom teardown, passed dialog and exchange + ;; Post-match history is a plist whose keys are exchange tags + ;; (symbols) and whose values are a cons of match-data and request + ;; values from prior matches. + (history nil :type list)) + +(defun erc-d--initialize-client (process) + "Initialize state variables used by a client PROCESS." + ;; Discard server-only/owned props + (process-put process :dialog-dialogs nil) + (let* ((server (process-get process :server)) + (reader (pop (process-get server :dialog-dialogs))) + (name (pop reader)) + ;; Copy handlers so they can self-mutate per process + (mat-h (copy-sequence (process-get process :dialog-match-handlers))) + (fqdn (copy-sequence (process-get process :dialog-server-fqdn))) + (vars (copy-sequence (process-get process :dialog-vars))) + (dialog (make-erc-d-dialog :name name + :process process + :queue (make-ring 5) + :exchanges (make-ring 10) + :match-handlers mat-h + :server-fqdn fqdn))) + ;; Add items expected by convenience commands like `erc-d-exchange-reload'. + (setf (alist-get 'EOF vars) `(: ,erc-d--eof-sentinel eot) + (alist-get 'LINGER vars) `(: ,erc-d--linger-sentinel eot) + (alist-get 'DROP vars) `(: ,erc-d--drop-sentinel eot) + (erc-d-dialog-vars dialog) vars + (erc-d-dialog-hunks dialog) reader) + ;; Add reverse link, register client, launch + (process-put process :dialog dialog) + (push process erc-d--clients) + (erc-d--command-refresh dialog nil) + (erc-d--on-request process))) + +(defun erc-d-load-replacement-dialog (dialog replacement &optional skip) + "Find REPLACEMENT among backlog and swap out current DIALOG's iterator. +With int SKIP, advance past that many exchanges." + (let* ((process (erc-d-dialog-process dialog)) + (server (process-get process :server)) + (reader (assoc-default replacement + (process-get server :dialog-dialogs) + #'eq))) + (when skip (while (not (zerop skip)) + (erc-d-u--read-dialog reader) + (cl-decf skip))) + (dolist (timer (erc-d-dialog-timers dialog)) + (cancel-timer timer)) + (dolist (exchange (ring-elements (erc-d-dialog-exchanges dialog))) + (cancel-timer (erc-d-exchange-timer exchange))) + (setf (erc-d-dialog-hunks dialog) reader) + (erc-d--command-refresh dialog nil))) + +(defvar erc-d--m-debug (getenv "ERC_D_DEBUG")) + +(defmacro erc-d--m (process format-string &rest args) + "Output ARGS using FORMAT-STRING somewhere depending on context. +PROCESS should be a client connection or a server network process." + `(let ((format-string (if erc-d--m-debug + (concat (format-time-string "%s.%N: ") + ,format-string) + ,format-string)) + (want-insert (and ,process erc-d--in-process))) + (when want-insert + (with-current-buffer (process-buffer (process-get ,process :server)) + (goto-char (point-max)) + (insert (concat (format ,format-string ,@args) "\n")))) + (when (or erc-d--m-debug (not want-insert)) + (message format-string ,@args)))) + +(defmacro erc-d--log (process string &optional outbound) + "Log STRING sent to (OUTBOUND) or received from PROCESS peer." + `(let ((id (or (process-get ,process :log-id) + (let ((port (erc-d-u--get-remote-port ,process))) + (process-put ,process :log-id port) + port))) + (name (erc-d-dialog-name (process-get ,process :dialog)))) + (if ,outbound + (erc-d--m process "-> %s:%s %s" name id ,string) + (dolist (line (split-string ,string "\r\n")) + (erc-d--m process "<- %s:%s %s" name id line))))) + +(defun erc-d--send (process string) + "Send STRING to PROCESS peer." + (erc-d--log process string 'outbound) + (process-send-string process (concat string "\r\n"))) + +(define-inline erc-d--fuzzy-p (exchange) + (inline-letevals (exchange) + (inline-quote + (let ((tag (symbol-name (erc-d-exchange-tag ,exchange)))) + (eq ?~ (aref tag 0)))))) + +(define-error 'erc-d-timeout "Timed out awaiting expected request") + +(defun erc-d--finalize-dialog (dialog) + "Delete client-connection and finalize DIALOG. +Return associated server." + (let ((process (erc-d-dialog-process dialog))) + (setq erc-d--clients (delq process erc-d--clients)) + (dolist (timer (erc-d-dialog-timers dialog)) + (cancel-timer timer)) + (dolist (exchange (ring-elements (erc-d-dialog-exchanges dialog))) + (cancel-timer (erc-d-exchange-timer exchange))) + (prog1 (process-get process :server) + (delete-process process)))) + +(defun erc-d--teardown (&optional sig &rest msg) + "Clean up processes and maybe send signal SIG using MSG." + (unless erc-d--in-process + (when sig + (erc-d--m nil "%s %s" sig (apply #'format-message msg))) + (kill-emacs (if msg 1 0))) + (let (process servers) + (while (setq process (pop erc-d--clients)) + (push (erc-d--finalize-dialog (process-get process :dialog)) servers)) + (dolist (server servers) + (delete-process server))) + (dolist (timer timer-list) + (when (memq (timer--function timer) + '(erc-d--send erc-d--command-handle-all)) + (erc-d--m nil "Stray timer found: %S" (timer--function timer)) + (cancel-timer timer))) + (when sig + (dolist (buf erc-d-u--canned-buffers) + (kill-buffer buf)) + (setq erc-d-u--canned-buffers nil) + (signal sig (list (apply #'format-message msg))))) + +(defun erc-d--teardown-this-dialog-at-least (dialog) + "Run `erc-d--teardown' after destroying DIALOG if it's the last one." + (let ((server (process-get (erc-d-dialog-process dialog) :server)) + (us (erc-d-dialog-process dialog))) + (erc-d--finalize-dialog dialog) + (cl-assert (not (memq us erc-d--clients))) + (unless (or (process-get server :dialog-dialogs) + (catch 'other + (dolist (process erc-d--clients) + (when (eq (process-get process :server) server) + (throw 'other process))))) + (push us erc-d--clients) + (erc-d--teardown)))) + +(defun erc-d--expire (dialog exchange) + "Raise timeout error for EXCHANGE. +This will start the teardown for DIALOG." + (setf (erc-d-exchange-spec exchange) nil) + (if-let ((finalizer (erc-d-dialog-finalizer dialog))) + (funcall finalizer dialog exchange) + (erc-d--teardown 'erc-d-timeout "Timed out awaiting request: %s" + (list :name (erc-d-exchange-tag exchange) + :pattern (erc-d-exchange-pattern exchange) + :timeout (erc-d-exchange-timeout exchange) + :dialog (erc-d-dialog-name dialog))))) + +;; Using `run-at-time' here allows test cases to examine replies as +;; they arrive instead of forcing tests to wait until an exchange +;; completes. The `run-at-time' in `erc-d--command-meter-replies' +;; does the same. When running as a subprocess, a normal while loop +;; with a `sleep-for' works fine (including with multiple dialogs). +;; FYI, this issue was still present in older versions that called +;; this directly from `erc-d--filter'. + +(defun erc-d--on-request (process) + "Handle one request for client-connection PROCESS." + (when (process-live-p process) + (let* ((dialog (process-get process :dialog)) + (queue (erc-d-dialog-queue dialog))) + (unless (ring-empty-p queue) + (let* ((parsed (ring-remove queue)) + (cmd (intern (erc-d-i-message.command parsed)))) + (setf (erc-d-dialog-message dialog) parsed) + (erc-d-command dialog cmd))) + (run-at-time nil nil #'erc-d--on-request process)))) + +(defun erc-d--drop-p (exchange) + (memq 'DROP (erc-d-exchange-inspec exchange))) + +(defun erc-d--linger-p (exchange) + (memq 'LINGER (erc-d-exchange-inspec exchange))) + +(defun erc-d--fake-eof (dialog) + "Simulate receiving a fictitious \"EOF\" message from peer." + (setf (erc-d-dialog-message dialog) ; use downcase for internal cmds + (make-erc-d-i-message :command "eof" :unparsed erc-d--eof-sentinel)) + (run-at-time nil nil #'erc-d-command dialog 'eof)) + +(defun erc-d--process-sentinel (process event) + "Set up or tear down client-connection PROCESS depending on EVENT." + (erc-d--m process "Connection %s: %s" process (string-trim-right event)) + (if (eq 'open (process-status process)) + (erc-d--initialize-client process) + (let* ((dialog (process-get process :dialog)) + (exes (and dialog (erc-d-dialog-exchanges dialog)))) + (if (and exes (not (ring-empty-p exes))) + (cond ((string-prefix-p "connection broken" event) + (erc-d--fake-eof dialog)) + ;; Ignore disconnecting peer when pattern is DROP + ((and (string-prefix-p "deleted" event) + (erc-d--drop-p (ring-ref exes -1)))) + (t (erc-d--teardown))) + (erc-d--teardown))))) + +(defun erc-d--filter (process string) + "Handle input received from peer. +PROCESS represents a client peer connection and STRING is a raw request +including line delimiters." + (let ((queue (erc-d-dialog-queue (process-get process :dialog)))) + (setq string (concat (process-get process :stashed-input) string)) + (while (and string (string-match (rx (+ "\r\n")) string)) + (let ((line (substring string 0 (match-beginning 0)))) + (setq string (unless (= (match-end 0) (length string)) + (substring string (match-end 0)))) + (erc-d--log process line nil) + (ring-insert queue (erc-d-i--parse-message line 'decode)))) + (when string + (setf (process-get process :stashed-input) string)))) + +;; Misc process properties: +;; +;; The server property `:dialog-dialogs' is an alist of (symbol +;; . erc-d-u-scan-d) conses, each of which pairs a dialogs name with +;; info on its read progress (described above in the Commentary). +;; This list is populated by `erc-d-run' at the start of each session. +;; +;; Client-connection processes keep a reference to their server via a +;; `:server' property, which can be used to share info with other +;; clients. There is currently no built-in way to do the same with +;; clients of other servers. Clients also keep references to their +;; dialogs and raw messages via `:dialog' and `:stashed-input'. +;; +;; The logger stores a unique, human-friendly process name in the +;; client-process property `:log-id'. + +(defun erc-d--start (host service name &rest plist) + "Serve canned replies on HOST at SERVICE. +Return the new server process immediately when `erc-d--in-process' is +non-nil. Otherwise, serve forever. PLIST becomes the plist of the +server process and is used to initialize the plists of connection +processes. NAME is used for the process and the buffer." + (let* ((buf (get-buffer-create (concat "*" name "*"))) + (proc (make-network-process :server t + :buffer buf + :noquery t + :filter #'erc-d--filter + :sentinel #'erc-d--process-sentinel + :name name + :family (if host 'ipv4 'local) + :coding 'binary + :service (or service t) + :host host + :plist plist))) + (process-put proc :server proc) + ;; We don't have a minor mode, so use an arbitrary variable to mark + ;; buffers owned by us instead + (with-current-buffer buf (setq erc-d-u--process-buffer t)) + (erc-d--m proc "Starting network process: %S %S" + proc (erc-d-u--format-bind-address proc)) + (if erc-d--in-process + proc + (while (process-live-p proc) + (accept-process-output nil 0.01))))) + +(defun erc-d--wrap-func-val (dialog exchange key func) + "Return a form invoking FUNC when evaluated. +Arrange for FUNC to be called with the args it expects based on +the description in `erc-d--render-entries'." + (let (args) + ;; Ignore &rest or &optional + (pcase-let ((`(,n . ,_) (func-arity func))) + (pcase n + (0) + (1 (push (apply-partially #'erc-d-exchange-multi dialog exchange key) + args)) + (2 (push exchange args) + (push (apply-partially #'erc-d-exchange-multi dialog exchange key) + args)) + (_ (error "Incompatible function: %s" func)))) + `(save-match-data (apply #',func ',args)))) + +(defun erc-d-exchange-reload (dialog exchange) + "Rebuild all bindings for EXCHANGE from those in DIALOG." + (cl-loop for (key . val) in (erc-d-dialog-vars dialog) + unless (keywordp key) do + (push (cons key val) (erc-d-exchange-bindings exchange)) + ;; Massage list so it's suitable for an `rx-list' binding. + ;; IOW, handle cases in which VAL is ([ARGLIST] RX-FORM) + ;; rather than just RX-FORM. KEY becomes the binding name. + (push (if (and (listp val) + (cdr val) + (not (cddr val)) + (consp (car val))) + (cons key val) + (list key val)) + (erc-d-exchange-rx-bindings exchange)) + and when (functionp val) do + (setq val + (erc-d--wrap-func-val dialog exchange key val)) + (push (list key val) (erc-d-exchange-labels exchange)))) + +(defun erc-d-exchange-rebind (dialog exchange key val &optional export) + "Modify a binding between renders. + +Bind symbol KEY to VAL, replacing whatever existed before, which may +have been a function. A third, optional argument, if present and +non-nil, results in the DIALOG's bindings for all EXCHANGEs adopting +this binding. VAL can either be a function of the type described in +`erc-d--render-entries' or any value acceptable as an argument to the +function `concat'. + +DIALOG and EXCHANGE are the current `erc-d-dialog' and `erc-d-exchange' +objects for the request context." + (when export + (setf (alist-get key (erc-d-dialog-vars dialog)) val)) + (if (functionp val) + (setf (alist-get key (erc-d-exchange-labels exchange)) + (list (erc-d--wrap-func-val dialog exchange key val))) + (setf (alist-get key (erc-d-exchange-labels exchange) nil 'rm) nil + (alist-get key (erc-d-exchange-rx-bindings exchange)) (list val) + (alist-get key (erc-d-exchange-bindings exchange)) val)) + val) + +(defun erc-d-exchange-match (exchange match-number &optional tag) + "Return match portion of current or previous request. +MATCH-NUMBER is the match group number. TAG, if provided, means the +exchange tag (name) from some previously matched request." + (if tag + (pcase-let* ((dialog (erc-d-exchange-dialog exchange)) + (`(,m-d . ,req) (plist-get (erc-d-dialog-history dialog) + tag))) + (set-match-data m-d) + (match-string match-number req)) + (match-string match-number (erc-d-exchange-request exchange)))) + +(defun erc-d-exchange-multi (dialog exchange key cmd &rest args) + "Call CMD with ARGS. +This is a utility helper passed as the first argument to all template +functions. DIALOG and EXCHANGE are pre-applied. A few pseudo commands, +like `:request', are provided for convenience so that the caller's +definition doesn't have to include this file. + +Command :get-var KEY looks up an item in `erc-d-dialog-vars'. Command +:get-binding KEY looks up an item in `erc-d-exchange-bindings'. Command +:set sets the template item triggered to a new VAL, optionally EXPORTing +it to `erc-d-dialog-vars'." + (pcase cmd + (:set (apply #'erc-d-exchange-rebind dialog exchange key args)) + (:reload (apply #'erc-d-exchange-reload dialog exchange args)) + (:rebind (apply #'erc-d-exchange-rebind dialog exchange args)) + (:match (apply #'erc-d-exchange-match exchange args)) + (:request (erc-d-exchange-request exchange)) + (:match-data (erc-d-exchange-match-data exchange)) + (:dialog-name (erc-d-dialog-name dialog)) + (:get-binding (cadr (assq (erc-d-exchange-bindings exchange) (car args)))) + (:get-var (alist-get (car args) (erc-d-dialog-vars dialog))))) + +(defun erc-d--prep-outgoing-entry (exchange entry) + "Construct current EXCHANGE ENTRY for rendering." + `(cl-symbol-macrolet ,(erc-d-exchange-labels exchange) + (set-match-data ',(erc-d-exchange-match-data exchange)) + ,(cons 'concat entry))) + +(defun erc-d--render-entries (exchange &optional yield-result) + "Act as an iterator producing rendered strings from EXCHANGE hunks. +When an entry's CAR is an arbitrary symbol, yield that back first, and +consider the entry an \"incoming\" entry. Then, regardless of the +entry's type (incoming or outgoing), yield back the next element, which +should be a number representing either a timeout (incoming) or a +delay (outgoing). After that, yield a rendered template (outgoing) or a +regular expression (incoming). + +When evaluating a template, bind the keys in the alist stored in the +dialog's `vars' field to its values, but skip any self-quoters, like +:foo. When an entry is incoming, replace occurrences of a key with its +value, which can be any valid `rx' form (see Info node `(elisp) +Extending Rx'). Do the same when an entry is outgoing, but expect a +value's form to be (anything that evaluates to) something acceptable by +`concat' or, alternatively, a function that returns the latter (meaning +a string or nil). + +Repeat the last two steps for the remaining entries, all of which are +assumed to be outgoing. That is, continue yielding a timeout/delay and +a rendered string for each entry, and yield nil when exhausted. + +Once again, for an incoming entry, the yielded string is a regexp to be +matched against the raw request. For outgoing, it's the final response, +ready to be sent out (after adding the appropriate line ending). + +To help with testing, bindings are not automatically created from +DIALOG's \"vars\" alist when this function is invoked. But this can be +forced by sending a non-nil YIELD-RESULT into the generator on the +second \"next\" invocation of a given iteration. This clobbers any +temporary bindings that don't exist in the DIALOG's `vars' alist, such +as those added via `erc-d-exchange-rebind' (unless \"exported\"). + +As noted earlier, template symbols can be bound to functions. When +called during rendering, the match data from the current (matched) +request is accessible by calling the function `match-data'. + +A function may ask for up to two required args, which are provided as +needed. When applicable, the first required arg is a `funcall'-able +helper that accepts various keyword-based commands, like :rebind, and a +variable number of args. See `erc-d-exchange-multi' for details. When +specified, the second required arg is the current `erc-d-exchange' +object, which has among its members its owning `erc-d-dialog' object. +This should suffice as a safety valve for any corner-case needs. +Non-required args are ignored." + (let ((spec (erc-d-exchange-spec exchange)) + (dialog (erc-d-exchange-dialog exchange)) + (entries (erc-d-exchange-hunk exchange))) + (unless (erc-d-spec-entry spec) + (setf (erc-d-spec-entry spec) (erc-d-u--read-exchange entries))) + (catch 'yield + (while (erc-d-spec-entry spec) + (pcase (erc-d-spec-state spec) + (0 (cl-incf (erc-d-spec-state spec)) + (throw 'yield (setf (erc-d-spec-head spec) + (pop (erc-d-spec-entry spec))))) + (1 (cl-incf (erc-d-spec-state spec)) + (when yield-result + (erc-d-exchange-reload dialog exchange)) + (if (numberp (erc-d-spec-head spec)) + (setf (erc-d-spec-entry spec) + (erc-d--prep-outgoing-entry exchange + (erc-d-spec-entry spec))) + (setf (erc-d-exchange-inspec exchange) (erc-d-spec-entry spec)) + (throw 'yield + (prog1 (pop (erc-d-spec-entry spec)) + (setf (erc-d-spec-entry spec) + `(rx-let ,(erc-d-exchange-rx-bindings exchange) + (rx bos ,@(erc-d-spec-entry spec)))))))) + (2 (setf (erc-d-spec-state spec) 0) + (throw 'yield + (prog1 (eval (erc-d-spec-entry spec) + (erc-d-exchange-bindings exchange)) + (setf (erc-d-spec-entry spec) nil))))))))) + +(defun erc-d--iter (exchange) + (apply-partially #'erc-d--render-entries exchange)) + +(defun erc-d-on-match (dialog exchange) + "Handle matched exchange request. +Allow the first handler in `erc-d-match-handlers' whose key matches TAG +to manipulate replies before they're sent to the DIALOG peer." + (when-let* ((tag (erc-d-exchange-tag exchange)) + (handler (plist-get (erc-d-dialog-match-handlers dialog) tag))) + (let ((md (erc-d-exchange-match-data exchange))) + (set-match-data md) + (funcall handler dialog exchange)))) + +(defun erc-d--send-outgoing (dialog exchange) + "Send outgoing lines for EXCHANGE to DIALOG peer. +Assume the next spec is outgoing. If its delay value is zero, render +the template and send the resulting message straight away. Do the same +when DELAY is negative, only arrange for its message to be sent (abs +DELAY) seconds later, and then keep on processing. If DELAY is +positive, pause processing and yield DELAY." + (let ((specs (erc-d--iter exchange)) + (process (erc-d-dialog-process dialog)) + (deferred (erc-d-exchange-deferred exchange)) + delay) + ;; Could stash/pass thunk instead to ensure specs can't be mutated + ;; between calls (by temporarily replacing dialog member with a fugazi) + (when deferred + (erc-d--send process (funcall specs)) + (setf deferred nil (erc-d-exchange-deferred exchange) deferred)) + (while (and (not deferred) (setq delay (funcall specs))) + (cond ((zerop delay) (erc-d--send process (funcall specs))) + ((< delay 0) (push (run-at-time (- delay) nil #'erc-d--send + process (funcall specs)) + (erc-d-dialog-timers dialog))) + ((setf deferred t (erc-d-exchange-deferred exchange) deferred)))) + delay)) + +(defun erc-d--add-dialog-linger (dialog exchange) + "Add finalizer for EXCHANGE in DIALOG." + (erc-d--m (erc-d-dialog-process dialog) + "Lingering for %.2f seconds" (erc-d-exchange-timeout exchange)) + (let ((start (current-time))) + (setf (erc-d-dialog-finalizer dialog) + (lambda (&rest _) + (erc-d--m (erc-d-dialog-process dialog) + "Lingered for %.2f seconds" + (float-time (time-subtract (current-time) start))) + (erc-d--teardown-this-dialog-at-least dialog))))) + +(defun erc-d--add-dialog-drop (dialog exchange) + "Add finalizer for EXCHANGE in DIALOG." + (erc-d--m (erc-d-dialog-process dialog) + "Dropping in %.2f seconds" (erc-d-exchange-timeout exchange)) + (setf (erc-d-dialog-finalizer dialog) + (lambda (&rest _) + (erc-d--m (erc-d-dialog-process dialog) + "Dropping %S" (erc-d-dialog-name dialog)) + (erc-d--finalize-dialog dialog)))) + +(defun erc-d--create-exchange (dialog hunk) + "Initialize next exchange HUNK for DIALOG." + (let* ((spec (make-erc-d-spec)) + (exchange (make-erc-d-exchange :dialog dialog :hunk hunk :spec spec)) + (specs (erc-d--iter exchange))) + (setf (erc-d-exchange-tag exchange) (funcall specs) + (erc-d-exchange-timeout exchange) (funcall specs t) + (erc-d-exchange-pattern exchange) (funcall specs)) + (cond ((erc-d--linger-p exchange) + (erc-d--add-dialog-linger dialog exchange)) + ((erc-d--drop-p exchange) + (erc-d--add-dialog-drop dialog exchange))) + (setf (erc-d-exchange-timer exchange) + (run-at-time (erc-d-exchange-timeout exchange) + nil #'erc-d--expire dialog exchange)) + exchange)) + +(defun erc-d--command-consider-prep-fail (dialog line exes) + (list 'error "Match failed: %S %S" line + (list :exes (mapcar #'erc-d-exchange-pattern + (ring-elements exes)) + :dialog (erc-d-dialog-name dialog)))) + +(defun erc-d--command-consider-prep-success (dialog line exes matched) + (setf (erc-d-exchange-request matched) line + (erc-d-exchange-match-data matched) (match-data) + ;; Also add current to match history, indexed by exchange tag + (plist-get (erc-d-dialog-history dialog) + (erc-d-exchange-tag matched)) + (cons (match-data) line)) ; do we need to make a copy of this? + (cancel-timer (erc-d-exchange-timer matched)) + (ring-remove exes (ring-member exes matched))) + +(cl-defun erc-d--command-consider (dialog) + "Maybe return next matched exchange for DIALOG. +Upon encountering a mismatch, return an error of the form (ERROR-SYMBOL +DATA). But when only fuzzies remain in the exchange pool, return nil." + (let* ((parsed (erc-d-dialog-message dialog)) + (line (erc-d-i-message.unparsed parsed)) + (exes (erc-d-dialog-exchanges dialog)) + ;; + matched) + (let ((elts (ring-elements exes))) + (while (and (setq matched (pop elts)) + (not (string-match (erc-d-exchange-pattern matched) line))) + (if (and (not elts) (erc-d--fuzzy-p matched)) + ;; Nothing to do, so advance + (cl-return-from erc-d--command-consider nil) + (cl-assert (or (not elts) (erc-d--fuzzy-p matched)))))) + (if matched + (erc-d--command-consider-prep-success dialog line exes matched) + (erc-d--command-consider-prep-fail dialog line exes)))) + +(defun erc-d--active-ex-p (ring) + "Return non-nil when RING has a non-fuzzy exchange. +That is, return nil when RING is empty or when it only has exchanges +with leading-tilde tags." + (let ((i 0) + (len (ring-length ring)) + ex found) + (while (and (not found) (< i len)) + (unless (erc-d--fuzzy-p (setq ex (ring-ref ring i))) + (setq found ex)) + (cl-incf i)) + found)) + +(defun erc-d--finalize-done (dialog) + ;; Linger logic for individual dialogs is handled elsewhere + (if-let ((finalizer (erc-d-dialog-finalizer dialog))) + (funcall finalizer dialog) + (let ((d (process-get (erc-d-dialog-process dialog) :dialog-linger-secs))) + (push (run-at-time d nil #'erc-d--teardown) + (erc-d-dialog-timers dialog))))) + +(defun erc-d--advance-or-die (dialog) + "Govern the lifetime of DIALOG. +Replenish exchanges from reader and insert them into the pool of +expected matches, as produced. Return a symbol indicating session +status: deferring, matching, depleted, or done." + (let ((exes (erc-d-dialog-exchanges dialog)) + hunk) + (cond ((erc-d--active-ex-p exes) 'deferring) + ((setq hunk (erc-d-u--read-dialog (erc-d-dialog-hunks dialog))) + (let ((exchange (erc-d--create-exchange dialog hunk))) + (if (erc-d--fuzzy-p exchange) + (ring-insert exes exchange) + (ring-insert-at-beginning exes exchange))) + 'matching) + ((not (ring-empty-p exes)) 'depleted) + (t 'done)))) + +(defun erc-d--command-meter-replies (dialog exchange &optional cmd) + "Ignore requests until all replies have been sent. +Do this for some previously matched EXCHANGE in DIALOG based on CMD, a +symbol. As a side effect, maybe schedule the resumption of the main +loop after some delay." + (let (delay) + (if (or (not cmd) (eq 'resume cmd)) + (when (setq delay (erc-d--send-outgoing dialog exchange)) + (push (run-at-time delay nil #'erc-d--command-handle-all + dialog 'resume) + (erc-d-dialog-timers dialog)) + (erc-d-dialog-state dialog)) + (setf (erc-d-dialog-state dialog) 'sending)))) + +(defun erc-d--die-unexpected (dialog) + (erc-d--teardown 'error "Received unexpected input: %S" + (erc-d-i-message.unparsed (erc-d-dialog-message dialog)))) + +(defun erc-d--command-refresh (dialog matched) + (let ((state (erc-d--advance-or-die dialog))) + (when (eq state 'done) + (erc-d--finalize-done dialog)) + (unless matched + (when (eq state 'depleted) + (erc-d--die-unexpected dialog)) + (cl-assert (memq state '(matching depleted)) t)) + (setf (erc-d-dialog-state dialog) state))) + +(defun erc-d--command-handle-all (dialog cmd) + "Create handler to act as control agent and process DIALOG requests. +Have it ingest internal control commands (lowercase symbols) and yield +back others indicating the lifecycle stage of the current dialog." + (let ((matched (erc-d-dialog-matched dialog))) + (cond + (matched + (or (erc-d--command-meter-replies dialog matched cmd) + (setf (erc-d-dialog-matched dialog) nil) + (erc-d--command-refresh dialog t))) + ((pcase cmd ; FIXME remove command facility or make extensible + ('resume nil) + ('eof (erc-d--m (erc-d-dialog-process dialog) "Received an EOF") nil))) + (t ; matching + (setq matched nil) + (catch 'yield + (while (not matched) + (when (ring-empty-p (erc-d-dialog-exchanges dialog)) + (erc-d--die-unexpected dialog)) + (when (setq matched (erc-d--command-consider dialog)) + (if (eq (car-safe matched) 'error) + (apply #'erc-d--teardown matched) + (erc-d-on-match dialog matched) + (setf (erc-d-dialog-matched dialog) matched) + (if-let ((s (erc-d--command-meter-replies dialog matched nil))) + (throw 'yield s) + (setf (erc-d-dialog-matched dialog) nil)))) + (erc-d--command-refresh dialog matched))))))) + +;;;; Handlers for IRC commands + +(cl-defgeneric erc-d-command ((dialog erc-d-dialog) cmd) + "Handle new CMD from client for DIALOG. +By default, defer to this dialog's `erc-d--command-handle-all' instance, +which is stored in its `handler' field." + (when (eq 'sending (erc-d--command-handle-all dialog cmd)) + (ring-insert-at-beginning (erc-d-dialog-queue dialog) + (erc-d-dialog-message dialog)))) + +;; A similar PONG handler would be useless because we know when to +;; expect them + +(cl-defmethod erc-d-command ((dialog erc-d-dialog) (_cmd (eql PING)) + &context (erc-d-auto-pong (eql t))) + "Respond to PING request from DIALOG peer when ERC-D-AUTO-PONG is t." + (let* ((parsed (erc-d-dialog-message dialog)) + (process (erc-d-dialog-process dialog)) + (nonce (car (erc-d-i-message.command-args parsed))) + (fqdn (erc-d-dialog-server-fqdn dialog))) + (erc-d--send process (format ":%s PONG %s :%s" fqdn fqdn nonce)))) + + +;;;; Entry points + +(defun erc-d-run (host service &optional server-name &rest dialogs) + "Start serving DIALOGS on HOST at SERVICE. +Pass HOST and SERVICE directly to `make-network-process'. When present, +use string SERVER-NAME for the server-process name as well as that of +its buffer (w. surrounding asterisks). When absent, do the same with +`erc-d-server-name'. When running \"in process,\" return the server +process, otherwise sleep for the duration of the server process. + +A dialog must be a symbol matching the base name of a dialog file in +`erc-d-u-canned-dialog-dir'. + +The variable `erc-d-spec-vars' determines the common members of the +`erc-d--render-entries' ENTRIES param. Variables `erc-d-server-fqdn' +and `erc-d-linger-secs' determine the `erc-d-dialog' items +`:server-fqdn' and `:linger-secs' for all client processes. + +The variable `erc-d-spec-vars' can be used to initialize the +process's `erc-d-dialog' vars item." + (when (and server-name (symbolp server-name)) + (push server-name dialogs) + (setq server-name nil)) + (let (loaded) + (dolist (dialog (nreverse dialogs)) + (let ((reader (erc-d-u--canned-load-dialog dialog))) + (when erc-d--slow-mo + (setq reader (erc-d-u--rewrite-for-slow-mo erc-d--slow-mo reader))) + (push (cons (erc-d-u--normalize-canned-name dialog) reader) loaded))) + (setq dialogs loaded)) + (erc-d--start host service (or server-name erc-d-server-name) + :dialog-dialogs dialogs + :dialog-vars erc-d-spec-vars + :dialog-linger-secs erc-d-linger-secs + :dialog-server-fqdn erc-d-server-fqdn + :dialog-match-handlers (erc-d-u--unkeyword + erc-d-match-handlers))) + +(defun erc-d-serve () + "Start serving canned dialogs from the command line. +Although not autoloaded, this function is meant to be summoned via the +Emacs -f flag while starting a batch session. It prints incoming and +outgoing messages to standard out. + +The main options are --host HOST and --port PORT, which default to +localhost and auto, respectively. The args are the dialogs to run. +Unlike with `erc-d-run', dialogs here *must* be file paths, meaning +Lisp-Data files adhering to the required format. (These consist of +\"specs\" detailing timing and template info; see commentary for +specifics.) + +An optional --add-time N option can also be passed to hike up timeouts +by some number of seconds N. For example, you might run: + + $ emacs -Q -batch -L . \\ + > -l erc-d.el \\ + > -f erc-d-serve \\ + > --host 192.168.124.1 \\ + > --port 16667 \\ + > --add-time 10 \\ + > ./my-dialog.eld + +from a Makefile or manually with \\\\[compile]. And then in +another terminal, do: + + $ nc -C 192.168.124.1 16667 ; or telnet if your nc doesn't have -C + > PASS changeme + ... + +Use `erc-d-run' instead to start the server from within Emacs." + (unless noninteractive + (error "Command-line func erc-d-serve not run in -batch session")) + (setq erc-d--in-process nil) + (let (port host dialogs erc-d--slow-mo) + (while command-line-args-left + (pcase (pop command-line-args-left) + ("--add-time" (setq erc-d--slow-mo + (string-to-number (pop command-line-args-left)))) + ("--linger" (setq erc-d-linger-secs + (string-to-number (pop command-line-args-left)))) + ("--host" (setq host (pop command-line-args-left))) + ("--port" (setq port (string-to-number (pop command-line-args-left)))) + (dialog (push dialog dialogs)))) + (setq dialogs (mapcar #'erc-d-u--massage-canned-name dialogs)) + (when erc-d--slow-mo + (message "Slow mo is ON")) + (apply #'erc-d-run (or host "localhost") port nil (nreverse dialogs)))) + +(provide 'erc-d) + +;;; erc-d.el ends here -- 2.35.1