add more error handlers and logging around notif/request handlers

src/blocking_IO.ml

@@ -9,7 +9,7 @@ let ( let* ) x f = f x
 let ( and+ ) a b = a, b
 let return x = x
 let failwith = failwith
-let fail = raise
+let fail = Printexc.raise_with_backtrace
 let stdin = stdin
 let stdout = stdout
 
@@ -24,7 +24,12 @@ let default_spawn f =
   in
   ignore (Thread.create run ())
 
-let catch f g = try f () with e -> g e
+let catch f g =
+  try f ()
+  with e ->
+    let bt = Printexc.get_raw_backtrace () in
+    g e bt
+
 let n_bytes_written = Atomic.make 0
 let n_bytes_read = Atomic.make 0
 

src/common_.ml

@@ -1,3 +1,4 @@
 module Trace = Trace_core
 
 let ( let@ ) = ( @@ )
+let spf = Printf.sprintf

src/jsonrpc2.ml

@@ -42,8 +42,6 @@ module Make (IO : IO) : S with module IO = IO = struct
 
   type json = J.t
 
-  let spf = Printf.sprintf
-
   module ErrorCode = Jsonrpc.Response.Error.Code
   (*
   module Err = struct
@@ -138,7 +136,7 @@ module Make (IO : IO) : S with module IO = IO = struct
       (fun () ->
         let+ x = f () in
         Ok x)
-      (fun e -> IO.return (Error e))
+      (fun e bt -> IO.return (Error (e, bt)))
 
   (** Sends a server notification to the LSP client. *)
   let send_server_notification (self : t) (n : Lsp.Server_notification.t) :
@@ -166,10 +164,15 @@ module Make (IO : IO) : S with module IO = IO = struct
   (** Wraps some action and, in case the [IO.t] request has failed, logs the
       failure to the LSP client. *)
   let with_error_handler (self : t) (action : unit -> unit IO.t) : unit IO.t =
-    IO.catch action (fun e ->
+    IO.catch action (fun exn bt ->
+        let message =
+          spf "LSP handler failed with %s\n%s" (Printexc.to_string exn)
+            (Printexc.raw_backtrace_to_string bt)
+        in
+        Log.err (fun k -> k "%s" message);
         let msg =
           Lsp.Types.LogMessageParams.create ~type_:Lsp.Types.MessageType.Error
-            ~message:(Printexc.to_string e)
+            ~message
         in
         let msg =
           Lsp.Server_notification.LogMessage msg
@@ -191,11 +194,12 @@ module Make (IO : IO) : S with module IO = IO = struct
 
   let handle_request (self : t) (r : Jsonrpc.Request.t) : unit IO.t =
     let protect ~id f =
-      IO.catch f (fun e ->
+      IO.catch f (fun e bt ->
           let message =
-            spf "%s\n%s" (Printexc.to_string e) (Printexc.get_backtrace ())
+            spf "%s\n%s" (Printexc.to_string e)
+              (Printexc.raw_backtrace_to_string bt)
           in
-          Log.err (fun k -> k "error: %s" message);
+          Log.err (fun k -> k "error in request handler: %s" message);
           let r =
             Jsonrpc.Response.error id
               (Jsonrpc.Response.Error.make
@@ -215,13 +219,23 @@ module Make (IO : IO) : S with module IO = IO = struct
               ~notify_back:(send_server_notification self)
               ~server_request:(server_request self)
           in
+          let response =
+            match reply with
+            | Ok reply ->
               let reply_json = Lsp.Client_request.yojson_of_result r reply in
-          let response = Jsonrpc.Response.ok id reply_json in
+              Jsonrpc.Response.ok id reply_json
+            | Error message ->
+              Jsonrpc.Response.error id
+                (Jsonrpc.Response.Error.make
+                   ~code:Jsonrpc.Response.Error.Code.InternalError ~message ())
+          in
+
           send_response self response
         | Error e -> IO.failwith (spf "cannot decode request: %s" e))
-      (fun e ->
+      (fun e bt ->
         let message =
-          spf "%s\n%s" (Printexc.to_string e) (Printexc.get_backtrace ())
+          spf "%s\n%s" (Printexc.to_string e)
+            (Printexc.raw_backtrace_to_string bt)
         in
         Log.err (fun k -> k "error: %s" message);
         let r =
@@ -273,7 +287,8 @@ module Make (IO : IO) : S with module IO = IO = struct
     | _ -> j
 
   (* read a full message *)
-  let read_msg (self : t) : (Jsonrpc.Packet.t, exn) result IO.t =
+  let read_msg (self : t) :
+      (Jsonrpc.Packet.t, exn * Printexc.raw_backtrace) result IO.t =
     let rec read_headers acc =
       let*? line = try_ @@ fun () -> IO.read_line self.ic in
       match String.trim line with
@@ -292,8 +307,9 @@ module Make (IO : IO) : S with module IO = IO = struct
          with
         | pair -> read_headers (pair :: acc)
         | exception _ ->
-          IO.return
-            (Error (E (ErrorCode.ParseError, spf "invalid header: %S" line))))
+          let bt = Printexc.get_raw_backtrace () in
+          let exn = E (ErrorCode.ParseError, spf "invalid header: %S" line) in
+          IO.return (Error (exn, bt)))
     in
     let*? headers = read_headers [] in
     Log.debug (fun k ->
@@ -323,15 +339,21 @@ module Make (IO : IO) : S with module IO = IO = struct
         (match Jsonrpc.Packet.t_of_yojson @@ fix_null_in_params j with
         | m -> IO.return @@ Ok m
         | exception exn ->
+          let bt = Printexc.get_raw_backtrace () in
           Log.err (fun k ->
-              k "cannot decode json message: %s" (Printexc.to_string exn));
-          IO.return (Error (E (ErrorCode.ParseError, "cannot decode json"))))
+              k "cannot decode json message: %s\n%s" (Printexc.to_string exn)
+                (Printexc.raw_backtrace_to_string bt));
+          let exn = E (ErrorCode.ParseError, "cannot decode json") in
+          IO.return (Error (exn, bt)))
       | exception _ ->
+        let bt = Printexc.get_raw_backtrace () in
         IO.return
-        @@ Error (E (ErrorCode.ParseError, "missing content-length' header"))
-    ) else
+        @@ Error (E (ErrorCode.ParseError, "missing content-length' header"), bt)
+    ) else (
+      let bt = Printexc.get_callstack 10 in
       IO.return
-      @@ Error (E (ErrorCode.InvalidRequest, "content-type must be 'utf-8'"))
+      @@ Error (E (ErrorCode.InvalidRequest, "content-type must be 'utf-8'"), bt)
+    )
 
   let send_server_request (self : t) (req : 'from_server Lsp.Server_request.t)
       (cb : ('from_server, Jsonrpc.Response.Error.t) result -> unit IO.t) :
@@ -369,7 +391,7 @@ module Make (IO : IO) : S with module IO = IO = struct
         | Ok r ->
           let* () = process_msg r in
           loop ()
-        | Error e -> IO.fail e
+        | Error (e, bt) -> IO.fail e bt
     in
     loop ()
 end

src/lwt/linol_lwt.ml

@@ -27,8 +27,12 @@ module IO_lwt :
   let write = Lwt_io.write_from_exactly
   let read = Lwt_io.read_into_exactly
   let read_line = Lwt_io.read_line
-  let catch = Lwt.catch
-  let fail = Lwt.fail
+
+  let catch f g =
+    let bt = Printexc.get_callstack 10 in
+    Lwt.catch f (fun exn -> g exn bt)
+
+  let fail e _bt = Lwt.fail e
 end
 
 (** Spawn function.

src/server.ml

@@ -60,7 +60,7 @@ module Make (IO : IO) = struct
             server_request:send_request ->
             id:Req_id.t ->
             'a Lsp.Client_request.t ->
-            'a IO.t
+            ('a, string) result IO.t
       (** Method called to handle client requests.
         @param notify_back an object used to reply to the client, send progress
         messages, diagnostics, etc.
@@ -150,6 +150,11 @@ module Make (IO : IO) = struct
   }
   (** Current state of a document. *)
 
+  let[@inline] lift_ok x =
+    let open IO in
+    let+ x = x in
+    Ok x
+
   (** An easily overloadable class. Pick the methods you want to support.
       The user must provide at least the callbacks for document lifecycle:
       open, close, update. The most basic LSP server should check documents
@@ -322,10 +327,24 @@ module Make (IO : IO) = struct
           server_request:_ ->
           id:Req_id.t ->
           r Lsp.Client_request.t ->
-          r IO.t =
+          (r, string) result IO.t =
         fun ~notify_back ~server_request ~id (r : _ Lsp.Client_request.t) ->
           Trace.with_span ~__FILE__ ~__LINE__ "linol.on-request"
-          @@ fun _sp : r IO.t ->
+          @@ fun _sp : (r, string) result IO.t ->
+          (* handler to catch all errors *)
+          let try_catch : (unit -> (r, _) result IO.t) -> (r, _) result IO.t =
+           fun f ->
+            IO.catch f (fun exn bt ->
+                let msg =
+                  spf "LSP request handler failed with %s\n%s"
+                    (Printexc.to_string exn)
+                    (Printexc.raw_backtrace_to_string bt)
+                in
+                Log.err (fun k -> k "%s" msg);
+                IO.return @@ Error msg)
+          in
+
+          try_catch @@ fun () ->
           Log.debug (fun k ->
               k "handle request[id=%s] <opaque>" (Req_id.to_string id));
 
@@ -333,7 +352,7 @@ module Make (IO : IO) = struct
           | Lsp.Client_request.Shutdown ->
             Log.info (fun k -> k "shutdown");
             status <- `ReceivedShutdown;
-            IO.return ()
+            IO.return @@ Ok ()
           | Lsp.Client_request.Initialize i ->
             Log.debug (fun k -> k "req: initialize");
             let notify_back =
@@ -341,21 +360,22 @@ module Make (IO : IO) = struct
                 ~partialResultToken:None ~workDoneToken:i.workDoneToken
                 ~notify_back ~server_request ()
             in
-            self#on_req_initialize ~notify_back i
+            lift_ok @@ self#on_req_initialize ~notify_back i
           | Lsp.Client_request.TextDocumentHover
               { textDocument; position; workDoneToken } ->
             let uri = textDocument.uri in
             Log.debug (fun k -> k "req: hover '%s'" (DocumentUri.to_path uri));
 
             (match Hashtbl.find_opt docs uri with
-            | None -> IO.return None
+            | None -> IO.return @@ Ok None
             | Some doc_st ->
               let notify_back =
                 new notify_back
                   ~workDoneToken ~partialResultToken:None ~uri ~notify_back
                   ~server_request ()
               in
-              self#on_req_hover ~notify_back ~id ~uri ~pos:position
+              lift_ok
+              @@ self#on_req_hover ~notify_back ~id ~uri ~pos:position
                    ~workDoneToken doc_st)
           | Lsp.Client_request.TextDocumentCompletion
               {
@@ -369,14 +389,15 @@ module Make (IO : IO) = struct
             Log.debug (fun k ->
                 k "req: complete '%s'" (DocumentUri.to_path uri));
             (match Hashtbl.find_opt docs uri with
-            | None -> IO.return None
+            | None -> IO.return @@ Ok None
             | Some doc_st ->
               let notify_back =
                 new notify_back
                   ~partialResultToken ~workDoneToken ~uri ~notify_back
                   ~server_request ()
               in
-              self#on_req_completion ~notify_back ~id ~uri ~workDoneToken
+              lift_ok
+              @@ self#on_req_completion ~notify_back ~id ~uri ~workDoneToken
                    ~partialResultToken ~pos:position ~ctx:context doc_st)
           | Lsp.Client_request.TextDocumentDefinition
               { textDocument; position; workDoneToken; partialResultToken } ->
@@ -390,9 +411,10 @@ module Make (IO : IO) = struct
             in
 
             (match Hashtbl.find_opt docs uri with
-            | None -> IO.return None
+            | None -> IO.return @@ Ok None
             | Some doc_st ->
-              self#on_req_definition ~notify_back ~id ~workDoneToken
+              lift_ok
+              @@ self#on_req_definition ~notify_back ~id ~workDoneToken
                    ~partialResultToken ~uri ~pos:position doc_st)
           | Lsp.Client_request.TextDocumentCodeLens
               { textDocument; workDoneToken; partialResultToken } ->
@@ -406,9 +428,10 @@ module Make (IO : IO) = struct
             in
 
             (match Hashtbl.find_opt docs uri with
-            | None -> IO.return []
+            | None -> IO.return @@ Ok []
             | Some doc_st ->
-              self#on_req_code_lens ~notify_back ~id ~uri ~workDoneToken
+              lift_ok
+              @@ self#on_req_code_lens ~notify_back ~id ~uri ~workDoneToken
                    ~partialResultToken doc_st)
           | Lsp.Client_request.TextDocumentCodeLensResolve cl ->
             Log.debug (fun k -> k "req: codelens resolve");
@@ -417,7 +440,7 @@ module Make (IO : IO) = struct
                 ~workDoneToken:None ~partialResultToken:None ~notify_back
                 ~server_request ()
             in
-            self#on_req_code_lens_resolve ~notify_back ~id cl
+            lift_ok @@ self#on_req_code_lens_resolve ~notify_back ~id cl
           | Lsp.Client_request.ExecuteCommand
               { command; arguments; workDoneToken } ->
             Log.debug (fun k -> k "req: execute command '%s'" command);
@@ -426,8 +449,9 @@ module Make (IO : IO) = struct
                 ~workDoneToken ~partialResultToken:None ~notify_back
                 ~server_request ()
             in
-            self#on_req_execute_command ~notify_back ~id ~workDoneToken command
-              arguments
+            lift_ok
+            @@ self#on_req_execute_command ~notify_back ~id ~workDoneToken
+                 command arguments
           | Lsp.Client_request.DocumentSymbol
               { textDocument = d; workDoneToken; partialResultToken } ->
             let notify_back =
@@ -435,7 +459,8 @@ module Make (IO : IO) = struct
                 ~workDoneToken ~partialResultToken ~notify_back ~server_request
                 ()
             in
-            self#on_req_symbol ~notify_back ~id ~uri:d.uri ~workDoneToken
+            lift_ok
+            @@ self#on_req_symbol ~notify_back ~id ~uri:d.uri ~workDoneToken
                  ~partialResultToken ()
           | Lsp.Client_request.CodeAction a ->
             let notify_back =
@@ -444,14 +469,15 @@ module Make (IO : IO) = struct
                 ~partialResultToken:a.partialResultToken ~notify_back
                 ~server_request ()
             in
-            self#on_req_code_action ~notify_back ~id a
+            lift_ok @@ self#on_req_code_action ~notify_back ~id a
           | Lsp.Client_request.InlayHint p ->
             let notify_back : notify_back =
               new notify_back
                 ~workDoneToken:p.workDoneToken ~partialResultToken:None
                 ~notify_back ~server_request ()
             in
-            self#on_req_inlay_hint ~notify_back ~id ~uri:p.textDocument.uri
+            lift_ok
+            @@ self#on_req_inlay_hint ~notify_back ~id ~uri:p.textDocument.uri
                  ~range:p.range ()
           | Lsp.Client_request.CodeActionResolve _
           | Lsp.Client_request.LinkedEditingRange _
@@ -492,14 +518,15 @@ module Make (IO : IO) = struct
                 ~workDoneToken:None ~partialResultToken:None ~notify_back
                 ~server_request ()
             in
-            self#on_request_unhandled ~notify_back ~id r
+            lift_ok @@ self#on_request_unhandled ~notify_back ~id r
           | Lsp.Client_request.UnknownRequest r ->
             let notify_back =
               new notify_back
                 ~workDoneToken:None ~partialResultToken:None ~notify_back
                 ~server_request ()
             in
-            self#on_unknown_request ~notify_back ~server_request ~id r.meth
+            lift_ok
+            @@ self#on_unknown_request ~notify_back ~server_request ~id r.meth
                  r.params
 
       method virtual on_notif_doc_did_open
@@ -535,6 +562,21 @@ module Make (IO : IO) = struct
         let@ _sp =
           Trace.with_span ~__FILE__ ~__LINE__ "linol.on-notification"
         in
+
+        (* handler to catch all errors *)
+        let try_catch : (unit -> unit IO.t) -> unit IO.t =
+         fun f ->
+          IO.catch f (fun exn bt ->
+              let msg =
+                spf "LSP notification handler failed with %s\n%s"
+                  (Printexc.to_string exn)
+                  (Printexc.raw_backtrace_to_string bt)
+              in
+              Log.err (fun k -> k "%s" msg);
+              IO.return ())
+        in
+
+        try_catch @@ fun () ->
         let open Lsp.Types in
         match n with
         | Lsp.Client_notification.TextDocumentDidOpen

src/sigs.ml

@@ -17,6 +17,6 @@ module type IO = sig
   val read_line : in_channel -> string t
   val write : out_channel -> bytes -> int -> int -> unit t
   val write_string : out_channel -> string -> unit t
-  val fail : exn -> unit t
-  val catch : (unit -> 'a t) -> (exn -> 'a t) -> 'a t
+  val fail : exn -> Printexc.raw_backtrace -> unit t
+  val catch : (unit -> 'a t) -> (exn -> Printexc.raw_backtrace -> 'a t) -> 'a t
 end