Correct signal descriptions in nrepl server sentinel (#2984) (#2984)

ikappaki · chaos · web-flow · commit 15eaf42922e5 · 2021-03-02T10:49:11.000+02:00
This is a workaround for Emacs 27.1 bug#46284 on Windows.

Co-authored-by: chaos &lt;chaos@localhost&gt;
diff --git a/CHANGELOG.md b/CHANGELOG.md
@@ -8,6 +8,7 @@
 
 ### Bugs fixed
 
+* [#2983](https://github.com/clojure-emacs/cider/issues/2983): update signal description in nrepl server sentinel as a workaround for emacs bug #46284 affecting v27.1 on windows
 * [#2941](https://github.com/clojure-emacs/cider/issues/2941): Use main args in alias for clojure cli
 * [#2953](https://github.com/clojure-emacs/cider/issues/2953): Don't font-lock function/macro vars as vars.
 * [#2964](https://github.com/clojure-emacs/cider/issues/2964): Fixes issue with `cider-company-enable-fuzzy-completion` and Helm
diff --git a/nrepl-client.el b/nrepl-client.el
@@ -1063,6 +1063,13 @@ been determined."
             (when nrepl-on-port-callback
               (funcall nrepl-on-port-callback (process-buffer process)))))))))
 
+(defmacro emacs-bug-46284/when-27.1-windows-nt (&rest body)
+  "Only evaluate BODY when Emacs bug #46284 has been detected."
+  (when (and (eq system-type 'windows-nt)
+             (string= emacs-version "27.1"))
+    (cons 'progn body)))
+
+
 (declare-function cider--close-connection "cider-connection")
 (defun nrepl-server-sentinel (process event)
   "Handle nREPL server PROCESS EVENT."
@@ -1075,6 +1082,19 @@ been determined."
                       (with-current-buffer server-buffer
                         (buffer-substring (point-min) (point-max)))
                     "")))
+    (emacs-bug-46284/when-27.1-windows-nt
+     ;; There is a bug in emacs 27.1 (since fixed) that sets all EVENT
+     ;; descriptions for signals to "unknown signal". We correct this by
+     ;; reseting it back to its canonical value.
+     (when (eq (process-status process) 'signal)
+       (cl-case (process-exit-status process)
+         ;; SIGHUP==1 emacs nt/inc/ms-w32.h
+         (1 (setq event "Hangup"))
+         ;; SIGINT==2 x86_64-w64-mingw32/include/signal.h
+         (2 (setq event "Interrupt"))
+         ;; SIGKILL==9 emacs nt/inc/ms-w32.h
+         (9 (setq event "Killed")))))
+
     (when server-buffer
       (kill-buffer server-buffer))
     (cond
diff --git a/test/nrepl-client-tests.el b/test/nrepl-client-tests.el
@@ -29,15 +29,20 @@
 
 (require 'buttercup)
 (require 'nrepl-client)
+(require 'nrepl-tests-utils)
 
 (describe "nrepl-server-buffer-name"
-  :var (nrepl-hide-special-buffers params default-directory
+  :var (nrepl-hide-special-buffers params default-directory-backup
                                    cider-session-name-template)
   (before-all
+    (setq default-directory-backup default-directory)
     (setq default-directory "/path/to/dirA/")
     (setq params '(:host "localhost" :port 1))
     (setq cider-session-name-template "%J:%h:%p"))
 
+  (after-all
+   (setq default-directory default-directory-backup))
+
   (describe "when nrepl-hide-special-buffers is t"
     (it "returns the name of the server buffer, which hides it in buffer changing commands"
       (setq nrepl-hide-special-buffers t
@@ -68,10 +73,15 @@
             '("2" "39f630b9-9545-4ea0-860e-9846681d0741" ("done")))))
 
 (describe "nrepl-make-buffer-name"
-  :var (default-directory cider-session-name-template)
+  :var (default-directory-backup cider-session-name-template)
   (before-all
+    (setq default-directory-backup default-directory)
     (setq default-directory "/path/to/dirA/")
     (setq cider-session-name-template "%J:%h:%p"))
+
+  (after-all
+   (setq default-directory default-directory-backup))
+
   (it "generates a buffer name from the given template"
     (let ((params '(:host "localhost" :port 1)))
       (expect (nrepl-make-buffer-name "*buff-name %s*" params)
@@ -100,3 +110,59 @@
                 :to-equal "*buff-name (cljs)*")
         (expect (nrepl-make-buffer-name "*buff-name %r:%S*" params)
                 :to-equal "*buff-name cljs*")))))
+
+(describe "nrepl-client-lifecycle"
+  (it "start and stop nrepl client process"
+
+      ;; start mock server
+      (let* ((server-buffer (get-buffer-create ":nrepl-lifecycle/server"))
+             (server-endpoint nil)
+             (server-process (nrepl-start-server-process
+                              default-directory
+                              (nrepl-server-mock-invocation-string)
+
+                              (lambda (endpoint)
+                                (setq server-endpoint nrepl-endpoint)
+                                server-buffer))))
+
+        ;; server up and running
+        (nrepl-tests-sleep-until 2 (eq (process-status server-process) 'run))
+        (expect (process-status server-process)
+                :to-equal 'run)
+
+        ;; server has reported its endpoint
+        (nrepl-tests-sleep-until 2 server-endpoint)
+        (expect server-endpoint :not :to-be nil)
+
+        (condition-case error-details
+            ;; start client process
+            (let* ((client-buffer (get-buffer-create ":nrepl-lifecycle/client"))
+                   (process-client (nrepl-start-client-process
+                                    (plist-get server-endpoint :host)
+                                    (plist-get server-endpoint :port)
+                                    server-process
+                                    (lambda (client-endpoint)
+                                      client-buffer))))
+
+              ;; client connection is open
+              (expect (process-status process-client)
+                      :to-equal 'open)
+
+              ;; provide some slack for server process to settle down
+              (sleep-for 0.2)
+
+              ;; exit client
+              (delete-process process-client)
+
+              ;; server process has been signalled
+              (nrepl-tests-sleep-until 4 (eq (process-status server-process)
+                                             'signal))
+              (expect (process-status server-process)
+                      :to-equal 'signal))
+          (error
+           ;; there may be some useful information in the nrepl buffer on error
+           (when-let ((nrepl-error-buffer (get-buffer "*nrepl-error*")))
+             (with-current-buffer nrepl-error-buffer
+               (message ":nrepl-lifecycle/error %s" (buffer-string))))
+           (error error-details))))))
+
diff --git a/test/nrepl-server-mock.el b/test/nrepl-server-mock.el
@@ -0,0 +1,105 @@
+;; nrepl-server-mock.el
+
+;; Copyright © 2021 Ioannis Kappas
+
+;; This file is NOT 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 `http://www.gnu.org/licenses/'.
+
+;;; Commentary:
+
+;; This file is part of CIDER
+;;
+;; A mock nREPL server that sends dummy replies back to clients with just enough
+;; information onboard to accommodate testing requirements.
+;;
+;; Meant to be invoked as the top-level fn of an emacs subprocess.
+
+;;; Code:
+
+(require 'nrepl-client)
+(require 'nrepl-tests-utils)
+(require 'queue)
+
+(defun nrepl-server-mock-filter (proc output)
+  "Handle the nREPL message found in OUTPUT sent by the client
+PROC. Minimal implementation, just enough for fulfilling clients' testing
+requirements."
+  (mock/log! ":mock.filter/output %s :msg %s" proc output)
+
+  (condition-case error-details
+      (let* ((msg (queue-dequeue (cdr (nrepl-bdecode output))))
+             (response (pcase msg
+                         (`(dict "op" "clone" "id" ,id)
+                          `(dict "id" ,id
+                                 "session" "a-session"
+                                 "status" ("done")
+			         "new-session" "a-new-session"))
+
+                         (`(dict "op" "describe" "session" ,session "id" ,id)
+                          `(dict "id" ,id "session" ,session "status"
+			         ("done"))))))
+
+        (mock/log! ":mock.filter/msg :in %s :out %s" msg response)
+        (if (not response)
+            (progn
+              (mock/log! ":mock.filter/unsupported-msg :in %s :msg %s"
+                         output msg)
+              (error ":mock.filter/unsupported-msg %s" output))
+
+          (progn
+            (mock/log! ":mock.filter/response-sending... %s" response)
+            (process-send-string proc (nrepl-bencode response)))))
+
+    (error
+     (mock/log! ":mock.filter/fatal-error %s" error-details)
+     (error error-details))
+
+
+    ))
+
+(defun nrepl-server-mock-start ()
+  "Start a mock nREPL server process. Prints out nREPL welcome message of
+the port and host it is started on. Exits after a 10 secs"
+
+  ;; change first argument to non-nil to enable logging to file
+  (nrepl-tests-log/init! nil mock "./nrepl-server-mock.log" 'new)
+  (mock/log! ":mock/starting...")
+
+  (let* ((server-process (make-network-process
+			  :name "server-mock/process"
+			  :server 't
+			  :host 'local
+                          ;; listen to an unoccupied port
+			  :service 't
+			  :buffer "server-mock/buffer"
+			  :filter 'nrepl-server-mock-filter
+			  :sentinel
+			  (lambda (proc status-change-descr)
+			    (mock/log! ":mock/process-status %s" status-change-descr))))
+	 (contact (process-contact server-process 't))
+         (mock-message (format "nREPL server started on port %d on host %s"
+                               (plist-get contact :service)
+                               (plist-get contact :host))))
+    ;; print welcome message
+    (message "%s%s" mock-message
+             (when  (eq system-type 'windows-nt)
+               ;; emacs bug #46388, emacs --batch's stderr is buffered under
+               ;; windows when not attached directly to the console; feed enough
+               ;; padding chars to flush the message out.
+               ;;
+               ;; https://debbugs.gnu.org/cgi/bugreport.cgi?bug=46388
+               (make-string (- 4096 (length mock-message)) ?*)))
+    (sleep-for 10)
+    (mock/log! ":mock/exiting...")))
diff --git a/test/utils/nrepl-tests-utils.el b/test/utils/nrepl-tests-utils.el
@@ -0,0 +1,102 @@
+;;; nrepl-test-utils.el
+
+;; Copyright © 2021 Ioannis Kappas
+
+;; This file is NOT 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 `http://www.gnu.org/licenses/'.
+
+;;; Commentary:
+
+;; useful utils for nREPL testing
+
+;; This file is part of CIDER
+
+;;; Code:
+
+(defmacro nrepl-tests-log/init! (enable? name log-filename &optional clean?)
+  "When ENABLE? is true, create a NAME/log! elisp function to log messages to LOG-FILENAME,
+taking the same arguments as `message'. Messages are appended to
+LOG-FILENAME, beginning with a :timestamp and followed up with :NAME. When
+CLEAN? is true remove LOG-FILENAME.
+
+If ENABLE? is nil, NAME/log! function is a nil macro discarding all
+arguments unevaluated.
+
+This logger fn is written in mind with multiple processes writing to the
+the same file, each having a unique name, in order to capture the order of
+events (e.g. a nREPL client process and mock server process writing to the
+same file).
+"
+  (let* ((log-file-path (file-truename log-filename))
+         (name-string (symbol-name name))
+         (log-symbol (intern (concat name-string "/log!"))))
+    (if enable? 
+        `(progn
+           (when ,clean?
+             (delete-file ,log-file-path))
+           (defun ,log-symbol (fmt &rest rest)
+             (let ((create-lockfiles nil)) ;; don't create lock files
+               (write-region (apply 'format (concat "%s :%s " fmt "\n")
+                                    (format-time-string "%H:%M:%S.%6N")
+                                    ,name-string
+                                    rest)
+                             nil ,log-file-path 'append))))
+
+      ;; send to the abyss!
+      `(defmacro ,log-symbol (fmt &rest rest)
+         '()))))
+
+(defmacro nrepl-tests-sleep-until (timeout-secs condition)
+  "Sleep for up to TIMEOUT-SECS or until CONDITION becomes true. It wakes
+up every 0.2 seconds to check for CONDITION."
+  (let* ((interval-secs 0.2)
+         (count (truncate (/ timeout-secs interval-secs))))
+    `(cl-loop repeat ,count
+              until ,condition
+              do (sleep-for ,interval-secs))))
+
+(defun nrepl-server-mock-invocation-string ()
+  "Return a shell command that can be used by nrepl-start-srever-process to
+invoke the mock nREPL server. The command will invoke emacs in --batch mode
+using the same load path, version and user package as the parent emacs
+calling process."
+  ;; try to use the same executable and user dirs as eldev
+  (concat "\"" (substring-no-properties (car command-line-args)) "\""
+          " -Q --batch"
+
+          ;; make sure to initialise packages
+          ;; so that the server can reference them.
+          " --eval \""
+          "(progn "
+          " (setf package-user-dir"
+          "       \\\"" package-user-dir "\\\""
+
+          "       load-path "
+          ;; maintain double quotes around paths,
+          ;; and also escape them with \
+          "       '" (replace-regexp-in-string
+                      "\"" (regexp-quote "\\\"") (prin1-to-string load-path))
+
+          "       user-emacs-directory"
+          "       \\\"" user-emacs-directory "\\\""
+          "  )"
+          " (package-initialize))"
+          "\""
+
+          ;; invoke mock server
+          " -l test/nrepl-server-mock.el -f nrepl-server-mock-start"))
+
+
+(provide 'nrepl-tests-utils)
