Improve tracing

Support tracing at an intermediate level, without message body details.
And let language servers change trace level on running servers.

Author: mainej

CHANGELOG.md

@@ -2,6 +2,9 @@
 
 ## Unreleased
 
+- Let language servers pick detail of traces, by setting `:trace-level`. #27
+- Let language servers set `:trace-level` on running lsp4clj server. #27
+
 ## v1.3.1
 
 ## v1.3.0

README.md

@@ -111,17 +111,21 @@ This will start listening on the provided port, blocking until a client makes a
 
 ### Tracing
 
-As you are implementing, you may want to trace incoming and outgoing messages. Initialize the server with `:trace? true` and then read traces (two element vectors, beginning with the log level `:debug` and ending with a string, the trace itself) off its `:trace-ch`.
+As you are implementing, you may want to trace incoming and outgoing messages. Initialize the server with `:trace-level "verbose"` and then read traces (two element vectors, beginning with the log level `:debug` and ending with a string, the trace itself) off its `:trace-ch`.
 
 ```clojure
-(let [server (lsp4clj.io-server/stdio-server {:trace? true})]
+(let [server (lsp4clj.io-server/stdio-server {:trace-level "verbose"})]
   (async/go-loop []
     (when-let [[level trace] (async/<! (:trace-ch server))]
       (logger/log level trace)
       (recur)))
   (lsp4clj.server/start server context))
 ```
 
+`:trace-level` can be set to `"off"` (no tracing), `"messages"` (to show just the message time, method, id and direction), or `"verbose"` (to also show details of the message body).
+
+The trace level can be changed during the life of a server by calling, for example, `(ls4clj.server/set-trace-level server "messages")`. This can be used to respect a trace level received at runtime, either in an [initialize](https://microsoft.github.io/language-server-protocol/specifications/lsp/3.17/specification/#initializeParams) request or a [$/setTrace](https://microsoft.github.io/language-server-protocol/specifications/lsp/3.17/specification/#setTrace) notification.
+
 ### Testing
 
 A client is in many ways like a server—it also sends and receives requests and notifications and receives responses. That is, LSP uses JSON-RPC as a bi-directional protocol. As such, you may be able to use some of lsp4clj's tools to build a mock client for testing. See `integration.client` in `clojure-lsp` for one such example.

src/lsp4clj/server.clj

@@ -9,7 +9,8 @@
    [lsp4clj.protocols.endpoint :as protocols.endpoint]
    [lsp4clj.trace :as trace]
    [promesa.core :as p])
-  (:import (java.util.concurrent CancellationException)))
+  (:import
+   (java.util.concurrent CancellationException)))
 
 (set! *warn-on-reflection* true)
 
@@ -154,15 +155,20 @@
                                     message-details)]
     (lsp.responses/error resp error-body)))
 
+(defn trace [{:keys [tracer* trace-ch]} trace-f & params]
+  (when-let [trace-body (apply trace-f @tracer* params)]
+    (async/put! trace-ch trace-body)))
+
 ;; TODO: https://microsoft.github.io/language-server-protocol/specifications/lsp/3.17/specification/#initialize
 ;; * receive-request should return error until initialize request is received
 ;; * receive-notification should drop until initialize request is received, with the exception of exit
 ;; * send-request should do nothing until initialize response is sent, with the exception of window/showMessageRequest
 ;; * send-notification should do nothing until initialize response is sent, with the exception of window/showMessage, window/logMessage, telemetry/event, and $/progress
 (defrecord ChanServer [input-ch
                        output-ch
-                       trace-ch
                        log-ch
+                       trace-ch
+                       tracer*
                        ^java.time.Clock clock
                        on-close
                        request-id*
@@ -207,32 +213,32 @@
           now (.instant clock)
           req (lsp.requests/request id method body)
           pending-request (pending-request id method now this)]
-      (some-> trace-ch (async/put! (trace/sending-request req now)))
+      (trace this trace/sending-request req now)
       ;; Important: record request before sending it, so it is sure to be
       ;; available during receive-response.
       (swap! pending-sent-requests* assoc id pending-request)
       ;; respect back pressure from clients that are slow to read; (go (>!)) will not suffice
       (async/>!! output-ch req)
       pending-request))
-  (send-notification [_this method body]
+  (send-notification [this method body]
     (let [now (.instant clock)
           notif (lsp.requests/notification method body)]
-      (some-> trace-ch (async/put! (trace/sending-notification notif now)))
+      (trace this trace/sending-notification notif now)
       ;; respect back pressure from clients that are slow to read; (go (>!)) will not suffice
       (async/>!! output-ch notif)))
-  (receive-response [_this {:keys [id error result] :as resp}]
+  (receive-response [this {:keys [id error result] :as resp}]
     (let [now (.instant clock)
           [pending-requests _] (swap-vals! pending-sent-requests* dissoc id)]
       (if-let [{:keys [p started] :as req} (get pending-requests id)]
         (do
-          (some-> trace-ch (async/put! (trace/received-response req resp started now)))
+          (trace this trace/received-response req resp started now)
           (deliver p (if error resp result)))
-        (some-> trace-ch (async/put! (trace/received-unmatched-response resp now))))))
+        (trace this trace/received-unmatched-response resp now))))
   (receive-request [this context {:keys [id method params] :as req}]
     (let [started (.instant clock)
           resp (lsp.responses/response id)]
       (try
-        (some-> trace-ch (async/put! (trace/received-request req started)))
+        (trace this trace/received-request req started)
         ;; coerce result/error to promise
         (let [result-promise (p/promise (receive-request method context params))]
           (swap! pending-received-requests* assoc id result-promise)
@@ -258,34 +264,41 @@
               (p/finally
                 (fn [resp _error]
                   (swap! pending-received-requests* dissoc id)
-                  (some-> trace-ch (async/put! (trace/sending-response req resp started (.instant clock))))
+                  (trace this trace/sending-response req resp started (.instant clock))
                   (async/>!! output-ch resp)))))
         (catch Throwable e ;; exceptions thrown by receive-request
           (log-error-receiving this e req)
           (async/>!! output-ch (internal-error-response resp req))))))
   (receive-notification [this context {:keys [method params] :as notif}]
     (let [now (.instant clock)]
-      (some-> trace-ch (async/put! (trace/received-notification notif now)))
+      (trace this trace/received-notification notif now)
       (if (= method "$/cancelRequest")
         (if-let [result-promise (get @pending-received-requests* (:id params))]
           (p/cancel! result-promise)
-          (some-> trace-ch (async/put! (trace/received-unmatched-cancellation-notification notif now))))
+          (trace this trace/received-unmatched-cancellation-notification notif now))
         (let [result (receive-notification method context params)]
           (when (identical? ::method-not-found result)
             (protocols.endpoint/log this :warn "received unexpected notification" method)))))))
 
+(defn set-trace-level [server trace-level]
+  (update server :tracer* reset! (trace/tracer-for-level trace-level)))
+
 (defn chan-server
-  [{:keys [output-ch input-ch log-ch trace? trace-ch clock on-close]
+  [{:keys [output-ch input-ch log-ch trace? trace-level trace-ch clock on-close]
     :or {clock (java.time.Clock/systemDefaultZone)
          on-close (constantly nil)}}]
-  (map->ChanServer
-    {:output-ch output-ch
-     :input-ch input-ch
-     :trace-ch (or trace-ch (and trace? (async/chan (async/sliding-buffer 20))))
-     :log-ch (or log-ch (async/chan (async/sliding-buffer 20)))
-     :clock clock
-     :on-close on-close
-     :request-id* (atom 0)
-     :pending-sent-requests* (atom {})
-     :pending-received-requests* (atom {})
-     :join (promise)}))
+  (let [trace-level (or trace-level
+                        (when (or trace? trace-ch) "verbose")
+                        "off")]
+    (map->ChanServer
+      {:output-ch output-ch
+       :input-ch input-ch
+       :log-ch (or log-ch (async/chan (async/sliding-buffer 20)))
+       :trace-ch (or trace-ch (async/chan (async/sliding-buffer 20)))
+       :tracer* (atom (trace/tracer-for-level trace-level))
+       :clock clock
+       :on-close on-close
+       :request-id* (atom 0)
+       :pending-sent-requests* (atom {})
+       :pending-received-requests* (atom {})
+       :join (promise)})))

src/lsp4clj/trace.clj

@@ -25,43 +25,116 @@
     (format-body "Error data" (:data error))
     (format-body "Result" result)))
 
-(defn ^:private format-trace [at direction message-type header-details body]
+(defn ^:private format-header [at direction message-type header-details]
+  (str (format-tag at) " " direction " " message-type " " header-details))
+
+(defn ^:private basic-trace [at direction message-type header-details]
+  [:debug
+   (format-header at direction message-type header-details)])
+
+(defn ^:private verbose-trace [at direction message-type header-details body]
   [:debug
-   (str (format-tag at) " " direction " " message-type " " header-details "\n"
+   (str (format-header at direction message-type header-details) "\n"
         body "\n\n\n")])
 
 (defn ^:private latency [^java.time.Instant started ^java.time.Instant finished]
   (format "%sms" (- (.toEpochMilli finished) (.toEpochMilli started))))
 
-(defn ^:private format-notification [direction notif at]
-  (format-trace at direction "notification" (format-notification-signature notif)
-                (format-params notif)))
-
-(defn ^:private format-request [direction req at]
-  (format-trace at direction "request" (format-request-signature req)
-                (format-params req)))
-
-(defn ^:private format-response [direction req {:keys [error] :as resp} started finished]
-  (format-trace finished direction "response"
-                (format
-                  (str "%s. Request took %s." (when error " Request failed: %s (%s)."))
-                  (format-request-signature req)
-                  (latency started finished)
-                  (:message error) (:code error))
-                (format-response-body resp)))
-
-(defn received-notification [notif at] (format-notification "Received" notif at))
-(defn received-request [req at] (format-request "Received" req at))
-(defn received-response [req resp started finished] (format-response "Received" req resp started finished))
-
-(defn received-unmatched-response [resp at]
-  (format-trace at "Received" "response" "for unmatched request:"
-                (format-body "Body" resp)))
-
-(defn received-unmatched-cancellation-notification [notif at]
-  (format-trace at "Received" "cancellation notification" (format "for unmatched request (%s):" (:id (:params notif)))
-                (format-params notif)))
-
-(defn sending-notification [notif at] (format-notification "Sending" notif at))
-(defn sending-request [req at] (format-request "Sending" req at))
-(defn sending-response [req resp started finished] (format-response "Sending" req resp started finished))
+(defn ^:private format-response-header-details [req {:keys [error]} started finished]
+  (format
+    (str "%s. Request took %s." (when error " Request failed: %s (%s)."))
+    (format-request-signature req)
+    (latency started finished)
+    (:message error) (:code error)))
+
+(defn ^:private format-unmatched-notif-header-details [notif]
+  (format "for unmatched request (%s):" (:id (:params notif))))
+
+(defn ^:private verbose-notification [direction notif at]
+  (verbose-trace at direction "notification" (format-notification-signature notif)
+                 (format-params notif)))
+
+(defn ^:private verbose-request [direction req at]
+  (verbose-trace at direction "request" (format-request-signature req)
+                 (format-params req)))
+
+(defn ^:private verbose-response [direction req resp started finished]
+  (verbose-trace finished direction "response"
+                 (format-response-header-details req resp started finished)
+                 (format-response-body resp)))
+
+(defn ^:private basic-notification [direction notif at]
+  (basic-trace at direction "notification" (format-notification-signature notif)))
+
+(defn ^:private basic-request [direction req at]
+  (basic-trace at direction "request" (format-request-signature req)))
+
+(defn ^:private basic-response [direction req resp started finished]
+  (basic-trace finished direction "response" (format-response-header-details req resp started finished)))
+
+(defprotocol ITracer
+  (received-notification [this notif at])
+  (received-request [this req at])
+  (received-response [this req resp started finished])
+  (received-unmatched-response [this resp at])
+  (received-unmatched-cancellation-notification [this notif at])
+  (sending-notification [this notif at])
+  (sending-request [this req at])
+  (sending-response [this req resp started finished]))
+
+(defrecord VerboseTracer []
+  ITracer
+  (received-notification [_this notif at]
+    (verbose-notification "Received" notif at))
+  (received-request [_this req at]
+    (verbose-request "Received" req at))
+  (received-response [_this req resp started finished]
+    (verbose-response "Received" req resp started finished))
+  (received-unmatched-response [_this resp at]
+    (verbose-trace at "Received" "response" "for unmatched request:"
+                   (format-body "Body" resp)))
+  (received-unmatched-cancellation-notification [_this notif at]
+    (verbose-trace at "Received" "cancellation notification" (format-unmatched-notif-header-details notif)
+                   (format-params notif)))
+  (sending-notification [_this notif at]
+    (verbose-notification "Sending" notif at))
+  (sending-request [_this req at]
+    (verbose-request "Sending" req at))
+  (sending-response [_this req resp started finished]
+    (verbose-response "Sending" req resp started finished)))
+
+(defrecord MessagesTracer []
+  ITracer
+  (received-notification [_this notif at]
+    (basic-notification "Received" notif at))
+  (received-request [_this req at]
+    (basic-request "Received" req at))
+  (received-response [_this req resp started finished]
+    (basic-response "Received" req resp started finished))
+  (received-unmatched-response [_this _resp at]
+    (basic-trace at "Received" "response" "for unmatched request:"))
+  (received-unmatched-cancellation-notification [_this notif at]
+    (basic-trace at "Received" "cancellation notification" (format-unmatched-notif-header-details notif)))
+  (sending-notification [_this notif at]
+    (basic-notification "Sending" notif at))
+  (sending-request [_this req at]
+    (basic-request "Sending" req at))
+  (sending-response [_this req resp started finished]
+    (basic-response "Sending" req resp started finished)))
+
+(defrecord SilentTracer []
+  ITracer
+  (received-notification [_this _notif _at])
+  (received-request [_this _req _at])
+  (received-response [_this _req _resp _started _finished])
+  (received-unmatched-response [_this _resp _at])
+  (received-unmatched-cancellation-notification [_this _notif _at])
+  (sending-notification [_this _notif _at])
+  (sending-request [_this _req _at])
+  (sending-response [_this _req _resp _started _finished]))
+
+(defn tracer-for-level [trace-level]
+  (case trace-level
+    "verbose" (VerboseTracer.)
+    "messages" (MessagesTracer.)
+    (SilentTracer.)))