Add integration tests support

Author: ericdallo

bb.edn

@@ -1,6 +1,8 @@
-{:paths ["scripts"]
+{:paths ["scripts" "integration-test"]
  :deps {borkdude/gh-release-artifact {:git/url "https://github.com/borkdude/gh-release-artifact"
-                                      :git/sha "4a9a74f0e50e897c45df8cc70684360eb30fce80"}}
+                                      :git/sha "4a9a74f0e50e897c45df8cc70684360eb30fce80"}
+        nubank/matcher-combinators {:mvn/version "3.9.1"}
+        com.github.clojure-lsp/lsp4clj {:mvn/version "1.13.1"}}
  :min-bb-version "0.8.156"
  :tasks {debug-cli make/debug-cli
          debug-graal make/debug-graal
@@ -10,4 +12,5 @@
          test make/unit-test
 
          tag make/tag
-         get-last-changelog-entry make/get-last-changelog-entry}}
+         get-last-changelog-entry make/get-last-changelog-entry
+         integration-test entrypoint/run-all}}

deps.edn

@@ -18,7 +18,8 @@
                      nrepl/nrepl {:mvn/version "1.3.0"}}}
   :test {:extra-deps {lambdaisland/kaocha {:mvn/version "1.91.1392"}
                       org.clojure/test.check {:mvn/version "1.1.1"}
-                      nubank/matcher-combinators {:mvn/version "3.9.1"}}
+                      nubank/matcher-combinators {:mvn/version "3.9.1"}
+                      http-kit/http-kit {:mvn/version "2.8.0"}}
          :jvm-opts ["-XX:-OmitStackTraceInFastThrow"]
          :extra-paths ["test"]
          :main-opts ["-m" "kaocha.runner"]}

integration-test/entrypoint.clj

@@ -0,0 +1,50 @@
+(ns entrypoint
+  (:require
+   [clojure.test :as t]))
+
+(def namespaces
+  '[integration.initialize-test])
+
+(defn timeout [timeout-ms callback]
+  (let [fut (future (callback))
+        ret (deref fut timeout-ms :timed-out)]
+    (when (= ret :timed-out)
+      (future-cancel fut))
+    ret))
+
+(declare ^:dynamic original-report)
+
+(defn log-tail-report [data]
+  (original-report data)
+  (when (contains? #{:fail :error} (:type data))
+    (println "Integration tests failed!")))
+
+(defmacro with-log-tail-report
+  "Execute body with modified test reporting functions that prints log tail on failure."
+  [& body]
+  `(binding [original-report t/report
+             t/report log-tail-report]
+     ~@body))
+
+#_{:clojure-lsp/ignore [:clojure-lsp/unused-public-var]}
+(defn run-all [& args]
+  (when-not (first args)
+    (println "First arg must be path to eca binary")
+    (System/exit 0))
+
+  (apply require namespaces)
+
+  (let [timeout-minutes (if (re-find #"(?i)win|mac" (System/getProperty "os.name"))
+                          10 ;; win and mac ci runs take longer
+                          5)
+        test-results (timeout (* timeout-minutes 60 1000)
+                              #(with-log-tail-report
+                                 (apply t/run-tests namespaces)))]
+
+    (when (= test-results :timed-out)
+      (println)
+      (println (format "Timeout after %d minutes running integration tests!" timeout-minutes))
+      (System/exit 1))
+
+    (let [{:keys [fail error]} test-results]
+      (System/exit (+ fail error)))))

integration-test/integration/client.clj

@@ -0,0 +1,202 @@
+(ns integration.client
+  (:require
+   [clojure.core.async :as async]
+   [clojure.string :as string]
+   [lsp4clj.coercer :as coercer]
+   [lsp4clj.io-chan :as lsp.io-chan]
+   [lsp4clj.lsp.requests :as lsp.requests]
+   [lsp4clj.lsp.responses :as lsp.responses]
+   [lsp4clj.protocols.endpoint :as protocols.endpoint])
+  (:import
+   [java.time LocalDateTime]
+   [java.time.format DateTimeFormatter]))
+
+(def ^:private ESC \u001b)
+
+(def ^:private colors
+  {:black     (str ESC "[30m")
+   :red-bg    (str ESC "[41m")
+   :red       (str ESC "[31m")
+   :green     (str ESC "[32m")
+   :yellow    (str ESC "[33m")
+   :blue      (str ESC "[34m")
+   :magenta   (str ESC "[35m")
+   :cyan      (str ESC "[36m")
+   :white     (str ESC "[37m")
+   :underline (str ESC "[4m")
+   :reset     (str ESC "[m")})
+
+(defn ^:private colored [color string]
+  (str (get colors color) string (:reset colors)))
+
+(def ^:private ld-formatter DateTimeFormatter/ISO_LOCAL_DATE_TIME)
+(defn ^:private local-datetime-str [] (.format ld-formatter (LocalDateTime/now)))
+
+(defprotocol IMockClient
+  (mock-response [this method body]))
+
+(defn ^:private format-log
+  [{:keys [client-id]} color msg params]
+  (string/join " "
+               [(local-datetime-str)
+                (colored color (str "Client " client-id " " msg))
+                (colored :yellow params)]))
+
+(defn ^:private receive-message
+  [client context message]
+  (println message)
+  (let [message-type (coercer/input-message-type message)]
+    (try
+      (let [response
+            (case message-type
+              (:parse-error :invalid-request)
+              (protocols.endpoint/log client :red "Error reading message" message-type)
+              :request
+              (protocols.endpoint/receive-request client context message)
+              (:response.result :response.error)
+              (protocols.endpoint/receive-response client message)
+              :notification
+              (protocols.endpoint/receive-notification client context message))]
+        ;; Ensure client only responds to requests
+        (when (identical? :request message-type)
+          response))
+      (catch Throwable e
+        (protocols.endpoint/log client :red "Error receiving:" e)
+        (throw e)))))
+
+(defonce client-id (atom 0))
+
+(defrecord Client [client-id
+                   input output
+                   log-ch
+                   join
+                   request-id sent-requests
+                   received-requests received-notifications
+                   mock-responses]
+  protocols.endpoint/IEndpoint
+  (start [this context]
+    (protocols.endpoint/log this :white "lifecycle:" "starting")
+    (let [pipeline (async/pipeline-blocking
+                    1 ;; no parallelism preserves server message order
+                    output
+                     ;; TODO: return error until initialize request is received? https://microsoft.github.io/language-server-protocol/specifications/lsp/3.17/specification/#initialize
+                     ;; `keep` means we do not reply to responses and notifications
+                    (keep #(receive-message this context %))
+                    input)]
+      (async/go
+        ;; wait for pipeline to close, indicating input closed
+        (async/<! pipeline)
+        (deliver join :done)))
+    ;; invokers can deref the return of `start` to stay alive until server is
+    ;; shut down
+    join)
+  (shutdown [this]
+    (protocols.endpoint/log this :white "lifecycle:" "shutting down")
+    ;; closing input will drain pipeline, then close output, then close
+    ;; pipeline
+    (async/close! input)
+    (if (= :done (deref join 10e3 :timeout))
+      (protocols.endpoint/log this :white "lifecycle:" "shutdown")
+      (protocols.endpoint/log this :red "lifecycle:" "shutdown timed out"))
+    (async/close! log-ch))
+  (log [this msg params]
+    (protocols.endpoint/log this :white msg params))
+  (log [this color msg params]
+    (async/put! log-ch (format-log this color msg params)))
+  (send-request [this method body]
+    (let [req (lsp.requests/request (swap! request-id inc) method body)
+          p (promise)
+          start-ns (System/nanoTime)]
+      (protocols.endpoint/log this :cyan "sending request:" req)
+      ;; Important: record request before sending it, so it is sure to be
+      ;; available during receive-response.
+      (swap! sent-requests assoc (:id req) {:request p
+                                            :start-ns start-ns})
+      (async/>!! output req)
+      p))
+  (send-notification [this method body]
+    (let [notif (lsp.requests/notification method body)]
+      (protocols.endpoint/log this :blue "sending notification:" notif)
+      (async/>!! output notif)))
+  (receive-response [this {:keys [id] :as resp}]
+    (if-let [{:keys [request start-ns]} (get @sent-requests id)]
+      (let [ms (float (/ (- (System/nanoTime) start-ns) 1000000))]
+        (protocols.endpoint/log this :green (format "received response (%.0fms):" ms) resp)
+        (swap! sent-requests dissoc id)
+        (deliver request (if (:error resp)
+                           resp
+                           (:result resp))))
+      (protocols.endpoint/log this :red "received response for unmatched request:" resp)))
+  (receive-request [this _ {:keys [id method] :as req}]
+    (protocols.endpoint/log this :magenta "received request:" req)
+    (swap! received-requests conj req)
+    (when-let [mock-resp (get @mock-responses (keyword method))]
+      (let [resp (lsp.responses/response id mock-resp)]
+        (protocols.endpoint/log this :magenta "sending mock response:" resp)
+        resp)))
+  (receive-notification [this _ notif]
+    (protocols.endpoint/log this :blue "received notification:" notif)
+    (swap! received-notifications conj notif))
+  IMockClient
+  (mock-response [_this method body]
+    (swap! mock-responses assoc method body)))
+
+(def start protocols.endpoint/start)
+(def shutdown protocols.endpoint/shutdown)
+(def send-notification protocols.endpoint/send-notification)
+
+(defn client [server-in server-out]
+  (map->Client
+   {:client-id (swap! client-id inc)
+    :input (lsp.io-chan/input-stream->input-chan server-out {:keyword-function keyword})
+    :output (lsp.io-chan/output-stream->output-chan server-in)
+    :log-ch (async/chan (async/sliding-buffer 20))
+    :join (promise)
+    :request-id (atom 0)
+    :sent-requests (atom {})
+    :received-requests (atom [])
+    :received-notifications (atom [])
+    :mock-responses (atom {})}))
+
+(defn ^:private keyname [key] (str (namespace key) "/" (name key)))
+
+(defn ^:private await-first-and-remove! [client pred coll-type]
+  (let [coll* (coll-type client)]
+    (loop [tries 0]
+      (if (< tries 20)
+        (if-let [elem (first (filter pred @coll*))]
+          (do
+            (swap! coll* #(->> % (remove #{elem}) vec))
+            elem)
+          (do
+            (Thread/sleep 500)
+            (recur (inc tries))))
+        (do
+          (protocols.endpoint/log client :red "timeout waiting:" coll-type)
+          (throw (ex-info "timeout waiting for client to receive req/notif" {:coll-type coll-type})))))))
+
+(defn await-server-notification [client method]
+  (let [method-str (keyname method)
+        notification (await-first-and-remove! client
+                                              #(= method-str (:method %))
+                                              :received-notifications)]
+    (:params notification)))
+
+(defn await-server-request [client method]
+  (let [method-str (keyname method)
+        msg (await-first-and-remove! client
+                                     #(= method-str (:method %))
+                                     :received-requests)]
+    (:params msg)))
+
+(defn request-and-await-server-response! [client method body]
+  (let [timeout-ms 180000
+        resp (deref (protocols.endpoint/send-request client method body)
+                    timeout-ms
+                    ::timeout)]
+    (if (= ::timeout resp)
+      (do
+        (protocols.endpoint/log client :red "timeout waiting for server response to client request:"
+                                {:method method :timeout-ms timeout-ms})
+        (throw (ex-info "timeout waiting for server response to client request" {:method method :body body})))
+      resp)))

integration-test/integration/eca.clj

@@ -0,0 +1,54 @@
+(ns integration.eca
+  (:require
+   [babashka.process :as p]
+   [clojure.core.async :as async]
+   [clojure.java.io :as io]
+   [clojure.test :refer [use-fixtures]]
+   [integration.client :as client]))
+
+(def ^:dynamic *eca-process* nil)
+(def ^:dynamic *mock-client* nil)
+
+(defn start-server
+  ([binary]
+   (start-server binary []))
+  ([binary args]
+   (p/process (into [(.getCanonicalPath (io/file binary)) "server" "--log-level" "debug"] args)
+              {:dir "integration-test/sample-test/"})))
+
+(defn start-process! []
+  (let [server (start-server (first *command-line-args*))
+        client (client/client (:in server) (:out server))]
+    (client/start client nil)
+    (async/go-loop []
+      (when-let [log (async/<! (:log-ch client))]
+        (println log)
+        (recur)))
+    (alter-var-root #'*eca-process* (constantly server))
+    (alter-var-root #'*mock-client* (constantly client))))
+
+(defn clean! []
+  (flush)
+  (some-> *mock-client* client/shutdown)
+  (some-> *eca-process* deref) ;; wait for shutdown of client to shutdown server
+  (alter-var-root #'*eca-process* (constantly nil))
+  (alter-var-root #'*mock-client* (constantly nil)))
+
+(defn clean-after-test []
+  (use-fixtures :each (fn [f] (clean!) (f)))
+  (use-fixtures :once (fn [f] (f) (clean!))))
+
+(defn notify! [[method body]]
+  (client/send-notification *mock-client* method body))
+
+(defn request! [[method body]]
+  (client/request-and-await-server-response! *mock-client* method body))
+
+(defn client-awaits-server-notification [method]
+  (client/await-server-notification *mock-client* method))
+
+(defn client-awaits-server-request [method]
+  (client/await-server-request *mock-client* method))
+
+(defn mock-response [method resp]
+  (client/mock-response *mock-client* method resp))

integration-test/integration/fixture.clj

@@ -0,0 +1,17 @@
+(ns integration.fixture
+  (:require
+   [clojure.java.io :as io]
+   [integration.helper :as h]))
+
+(def default-init-options {:pureConfig true})
+
+(defn initialize-request
+  ([]
+   (initialize-request {:initializationOptions default-init-options}))
+  ([params]
+   (initialize-request params [{:name "sample-test"
+                                :uri (h/file->uri (io/file h/default-root-project-path))}]))
+  ([params workspace-folders]
+   [:initialize
+    (merge (if workspace-folders {:workspace-folders workspace-folders} {})
+           params)]))

integration-test/integration/helper.clj

@@ -0,0 +1,36 @@
+(ns integration.helper
+  (:require
+   [babashka.fs :as fs]
+   [clojure.java.io :as io]
+   [clojure.string :as string]))
+
+(def windows?
+  "Whether is running on MS-Windows."
+  (string/starts-with? (System/getProperty "os.name") "Windows"))
+
+(def ^:dynamic *escape-uris?* false)
+
+(def default-root-project-path
+  (-> (io/file *file*)
+      .getParentFile
+      .getParentFile
+      (fs/path "sample-test")
+      fs/canonicalize
+      str))
+
+(defn escape-uri
+  "Escapes enough URI characters for testing purposes and returns it.
+
+  On MS-Windows, it will also escape the drive colon, mimicking
+  VS-Code/Calva's behavior."
+  [uri]
+  ;; Do a better escape considering more chars
+  (cond-> (string/replace uri "::" "%3A%3A")
+    windows?
+    (string/replace  #"/([a-zA-Z]):/" "/$1%3A/")))
+
+(defn file->uri [file]
+  (let [uri (-> file fs/canonicalize .toUri .toString)]
+    (if *escape-uris?*
+      (escape-uri uri)
+      uri)))