From d3fc3ce7e70df0a92931c31fcadb625d81b9f0bc Mon Sep 17 00:00:00 2001
From: =?utf8?q?Jo=C3=A3o=20T=C3=A1vora?= <joaotavora@gmail.com>
Date: Fri, 23 Nov 2018 12:31:15 +0000
Subject: [PATCH] Control strictness towards incoming lsp messages

A new variable, eglot-strict-mode controls whether Eglot is strict or
lax with regard to incoming LSP messages.

1. Bug reports should be tested with eglot-strict-mode set to
   '(disallow-non-standard-keys enforce-required-keys)

2. Users struggling to get non-standard servers working set this
   variable to '(), nil.  For now, by popular demand, this is the
   default value.

Note that this commit in particular introduces a new infrastructure,
but does not yet alter any code in Eglot to use it.  Neither is the
variable eglot--lsp-interface-alist populated.

* eglot-tests.el (eglot-strict-interfaces): New test.

* eglot.el (eglot--lsp-interface-alist): New variable.
(eglot-strict-mode): New variable.
(eglot--call-with-interface): New helper.
(eglot--dbind): New macro.
(eglot--lambda): New macro.

GitHub-reference: per https://github.com/joaotavora/eglot/issues/144
GitHub-reference: per https://github.com/joaotavora/eglot/issues/156
---
 lisp/progmodes/eglot.el | 88 +++++++++++++++++++++++++++++++++++++++++
 1 file changed, 88 insertions(+)

diff --git a/lisp/progmodes/eglot.el b/lisp/progmodes/eglot.el
index 365b5d21817..4996f5b639a 100644
--- a/lisp/progmodes/eglot.el
+++ b/lisp/progmodes/eglot.el
@@ -197,6 +197,94 @@ let the buffer grow forever."
     (13 . "Enum") (14 . "Keyword") (15 . "Snippet") (16 . "Color")
     (17 . "File") (18 . "Reference")))
 
+
+
+;;; Message verification helpers
+;;;
+(defvar eglot--lsp-interface-alist `()
+  "Alist (INTERFACE-NAME . INTERFACE) of known external LSP interfaces.
+
+INTERFACE-NAME is a symbol designated by the spec as \"export
+interface\".  INTERFACE is a list (REQUIRED OPTIONAL) where
+REQUIRED and OPTIONAL are lists of keyword symbols designating
+field names that must be, or may be, respectively, present in a
+message adhering to that interface.
+
+Here's what an element of this alist might look like:
+
+    (CreateFile . ((:kind :uri) (:options)))")
+
+(defvar eglot-strict-mode '()
+  "How strictly Eglot vetoes LSP messages from server.
+
+Value is a list of symbols:
+
+If a list containing the symbol `disallow-non-standard-keys', an
+error is raised if any non-standard fields are sent by the
+server.
+
+If the list containing the symbol `enforce-required-keys', an error
+is raised if any required fields are missing from the message.
+
+If the list is empty, any non-standard fields sent by the server
+and missing required fields are accepted (which may or may not
+cause problems in Eglot's functioning later on).")
+
+(defun eglot--call-with-interface (interface object fn)
+  "Call FN, but first check that OBJECT conforms to INTERFACE.
+
+INTERFACE is a key to `eglot--lsp-interface-alist' and OBJECT is
+  a plist representing an LSP message."
+  (let* ((entry (assoc interface eglot--lsp-interface-alist))
+         (required (car (cdr entry)))
+         (optional (cadr (cdr entry))))
+    (when (memq 'enforce-required-keys eglot-strict-mode)
+      (cl-loop for req in required
+               when (eq 'eglot--not-present
+                        (cl-getf object req 'eglot--not-present))
+               collect req into missing
+               finally (when missing
+                         (eglot--error
+                          "A `%s' must have %s" interface missing))))
+    (when (and entry (memq 'disallow-non-standard-keys eglot-strict-mode))
+      (cl-loop
+       with allowed = (append required optional)
+       for (key _val) on object by #'cddr
+       unless (memq key allowed) collect key into disallowed
+       finally (when disallowed
+                 (eglot--error
+                  "A `%s' mustn't have %s" interface disallowed))))
+    (funcall fn)))
+
+(cl-defmacro eglot--dbind (interface lambda-list object &body body)
+  "Destructure OBJECT of INTERFACE as CL-LAMBDA-LIST.
+Honour `eglot-strict-mode'."
+  (declare (indent 3))
+  (let ((fn-once `(lambda () ,@body))
+        (lax-lambda-list (if (memq '&allow-other-keys lambda-list)
+                             lambda-list
+                           (append lambda-list '(&allow-other-keys))))
+        (strict-lambda-list (delete '&allow-other-keys lambda-list)))
+    (if interface
+        `(cl-destructuring-bind ,lax-lambda-list ,object
+           (eglot--call-with-interface ',interface ,object ,fn-once))
+      (let ((object-once (make-symbol "object-once")))
+        `(let ((,object-once ,object))
+           (if (memq 'disallow-non-standard-keys eglot-strict-mode)
+               (cl-destructuring-bind ,strict-lambda-list ,object-once
+                 (funcall ,fn-once))
+             (cl-destructuring-bind ,lax-lambda-list ,object-once
+               (funcall ,fn-once))))))))
+
+(cl-defmacro eglot--lambda (interface cl-lambda-list &body body)
+  "Function of args CL-LAMBDA-LIST for processing INTERFACE objects.
+Honour `eglot-strict-mode'."
+  (declare (indent 2))
+  (let ((e (cl-gensym "jsonrpc-lambda-elem")))
+    `(lambda (,e)
+       (eglot--dbind ,interface ,cl-lambda-list ,e
+         ,@body))))
+
 
 ;;; API (WORK-IN-PROGRESS!)
 ;;;
-- 
2.39.2