mirror of
https://github.com/c-cube/linol.git
synced 2025-12-05 19:00:34 -05:00
Handle server requests
Problem: Linol can only send notifications from the server to the client, but not requests. Solution: The solution was inspired by Haskell's `lsp` package. We first maintain a `server_request_handler_pair` data structure which represents some server request and its associated response handler. Now `notify_back` may take these fields and use it to actually handle a request and its response. Changes to `notify_back` are propagated throughout `server.ml`. On `jsonrpc2.ml`, we refactor the notification and request handlers so that we may handle the response and batch response handlers and batch call as a courtesy. For a response, we keep a hash table that tracks an ID to the `server_request_handler_pair` in other to be able to call the handler that was associated with the response. After we get such response (indexed by the server request's ID), we remove it from the hash table to prevent a memory leak. Since the server needs to keep track of the server request IDs, I added a mutable `id_counter` in order to generate a fresh LSP ID (using `fresh_lsp_id`) for every outgoing request. For debugging, if we error while decoding a JSON, I now print the exception too.
This commit is contained in:
parent
d418ea010a
commit
5388f58530
2 changed files with 221 additions and 89 deletions
230
src/jsonrpc2.ml
230
src/jsonrpc2.ml
|
|
@ -60,9 +60,13 @@ module Make (IO : IO) : S with module IO = IO = struct
|
|||
ic: IO.in_channel;
|
||||
oc: IO.out_channel;
|
||||
s: server;
|
||||
mutable id_counter: int;
|
||||
pending_responses: (Req_id.t, server_request_handler_pair) Hashtbl.t;
|
||||
}
|
||||
|
||||
let create ~ic ~oc server : t = { ic; oc; s = server }
|
||||
let create ~ic ~oc server : t =
|
||||
{ ic; oc; s = server; id_counter = 0; pending_responses = Hashtbl.create 8 }
|
||||
|
||||
let create_stdio server : t = create ~ic:IO.stdin ~oc:IO.stdout server
|
||||
|
||||
(* send a single message *)
|
||||
|
|
@ -82,6 +86,27 @@ module Make (IO : IO) : S with module IO = IO = struct
|
|||
let json = Jsonrpc.Notification.yojson_of_t m in
|
||||
send_json_ self json
|
||||
|
||||
let send_server_req (self : t) (m : Jsonrpc.Request.t) : unit IO.t =
|
||||
let json = Jsonrpc.Request.yojson_of_t m in
|
||||
send_json_ self json
|
||||
|
||||
(** Returns a new, unused [Req_id.t] to send a server request. *)
|
||||
let fresh_lsp_id (self : t) : Req_id.t =
|
||||
let id = self.id_counter in
|
||||
self.id_counter <- id + 1;
|
||||
`Int id
|
||||
|
||||
(** Registers a new handler for a request response. The return indicates
|
||||
whether a value was inserted or not (in which case it's already present). *)
|
||||
let register_server_request_response_handler (self : t) (id : Req_id.t)
|
||||
(handler : server_request_handler_pair) : bool =
|
||||
if Hashtbl.mem self.pending_responses id then
|
||||
false
|
||||
else (
|
||||
let () = Hashtbl.add self.pending_responses id handler in
|
||||
true
|
||||
)
|
||||
|
||||
let try_ f =
|
||||
IO.catch
|
||||
(fun () ->
|
||||
|
|
@ -89,6 +114,134 @@ module Make (IO : IO) : S with module IO = IO = struct
|
|||
Ok x)
|
||||
(fun e -> IO.return (Error e))
|
||||
|
||||
(** Sends a server notification to the LSP client. *)
|
||||
let server_notification (self : t) (n : Lsp.Server_notification.t) : unit IO.t
|
||||
=
|
||||
let msg = Lsp.Server_notification.to_jsonrpc n in
|
||||
send_server_notif self msg
|
||||
|
||||
(** Given a [server_request_handler_pair] consisting of some server request
|
||||
and its handler, sends this request to the LSP client and adds the handler
|
||||
to a table of pending responses. The request will later be handled by
|
||||
[handle_response], which will call the provided handler and delete it from
|
||||
the table of pending responses. *)
|
||||
let server_request (self : t) (req : server_request_handler_pair) :
|
||||
Req_id.t IO.t =
|
||||
let (Request_and_handler (r, _)) = req in
|
||||
let id = fresh_lsp_id self in
|
||||
let msg = Lsp.Server_request.to_jsonrpc_request r ~id in
|
||||
let has_inserted = register_server_request_response_handler self id req in
|
||||
if has_inserted then
|
||||
let* () = send_server_req self msg in
|
||||
return id
|
||||
else
|
||||
IO.failwith "failed to register server request: id was already used"
|
||||
|
||||
(** 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 ->
|
||||
let msg =
|
||||
Lsp.Types.LogMessageParams.create ~type_:Lsp.Types.MessageType.Error
|
||||
~message:(Printexc.to_string e)
|
||||
in
|
||||
let msg =
|
||||
Lsp.Server_notification.LogMessage msg
|
||||
|> Lsp.Server_notification.to_jsonrpc
|
||||
in
|
||||
send_server_notif self msg)
|
||||
|
||||
let handle_notification (self : t) (n : Jsonrpc.Notification.t) : unit IO.t =
|
||||
match Lsp.Client_notification.of_jsonrpc n with
|
||||
| Ok n ->
|
||||
with_error_handler self (fun () ->
|
||||
self.s#on_notification n ~notify_back:(server_notification self)
|
||||
~server_request:(server_request self))
|
||||
| Error e -> IO.failwith (spf "cannot decode notification: %s" e)
|
||||
|
||||
let handle_request (self : t) (r : Jsonrpc.Request.t) : unit IO.t =
|
||||
let protect ~id f =
|
||||
IO.catch f (fun e ->
|
||||
let message =
|
||||
spf "%s\n%s" (Printexc.to_string e) (Printexc.get_backtrace ())
|
||||
in
|
||||
Log.err (fun k -> k "error: %s" message);
|
||||
let r =
|
||||
Jsonrpc.Response.error id
|
||||
(Jsonrpc.Response.Error.make
|
||||
~code:Jsonrpc.Response.Error.Code.InternalError ~message ())
|
||||
in
|
||||
send_response self r)
|
||||
in
|
||||
(* request, so we need to reply *)
|
||||
let id = r.id in
|
||||
IO.catch
|
||||
(fun () ->
|
||||
match Lsp.Client_request.of_jsonrpc r with
|
||||
| Ok (Lsp.Client_request.E r) ->
|
||||
protect ~id (fun () ->
|
||||
let* reply =
|
||||
self.s#on_request r ~id ~notify_back:(server_notification self)
|
||||
~server_request:(server_request self)
|
||||
in
|
||||
let reply_json = Lsp.Client_request.yojson_of_result r reply in
|
||||
let response = Jsonrpc.Response.ok id reply_json in
|
||||
send_response self response)
|
||||
| Error e -> IO.failwith (spf "cannot decode request: %s" e))
|
||||
(fun e ->
|
||||
let message =
|
||||
spf "%s\n%s" (Printexc.to_string e) (Printexc.get_backtrace ())
|
||||
in
|
||||
Log.err (fun k -> k "error: %s" message);
|
||||
let r =
|
||||
Jsonrpc.Response.error id
|
||||
(Jsonrpc.Response.Error.make
|
||||
~code:Jsonrpc.Response.Error.Code.InternalError ~message ())
|
||||
in
|
||||
send_response self r)
|
||||
|
||||
let handle_response (self : t) (r : Jsonrpc.Response.t) : unit IO.t =
|
||||
match Hashtbl.find_opt self.pending_responses r.id with
|
||||
| None ->
|
||||
IO.failwith
|
||||
@@ Printf.sprintf "server request not found for response of id %s"
|
||||
@@ Req_id.to_string r.id
|
||||
| Some (Request_and_handler (req, handler)) ->
|
||||
let () = Hashtbl.remove self.pending_responses r.id in
|
||||
(match r.result with
|
||||
| Error err -> with_error_handler self (fun () -> handler @@ Error err)
|
||||
| Ok json ->
|
||||
let r = Lsp.Server_request.response_of_json req json in
|
||||
with_error_handler self (fun () -> handler @@ Ok r))
|
||||
|
||||
let handle_batch_response (self : t) (rs : Jsonrpc.Response.t list) :
|
||||
unit IO.t =
|
||||
let rec go = function
|
||||
| [] -> IO.return ()
|
||||
| r :: rs ->
|
||||
let* () = handle_response self r in
|
||||
go rs
|
||||
in
|
||||
go rs
|
||||
|
||||
let handle_batch_call (self : t)
|
||||
(cs :
|
||||
[ `Notification of Jsonrpc.Notification.t
|
||||
| `Request of Jsonrpc.Request.t
|
||||
]
|
||||
list) : unit IO.t =
|
||||
let rec go = function
|
||||
| [] -> IO.return ()
|
||||
| c :: cs ->
|
||||
let* () =
|
||||
match c with
|
||||
| `Notification n -> handle_notification self n
|
||||
| `Request r -> handle_request self r
|
||||
in
|
||||
go cs
|
||||
in
|
||||
go cs
|
||||
|
||||
(* read a full message *)
|
||||
let read_msg (self : t) : (Jsonrpc.Packet.t, exn) result IO.t =
|
||||
let rec read_headers acc =
|
||||
|
|
@ -137,8 +290,9 @@ module Make (IO : IO) : S with module IO = IO = struct
|
|||
Log.debug (fun k -> k "got json %s" (J.to_string j));
|
||||
(match Jsonrpc.Packet.t_of_yojson j with
|
||||
| m -> IO.return @@ Ok m
|
||||
| exception _ ->
|
||||
Log.err (fun k -> k "cannot decode json message");
|
||||
| exception exn ->
|
||||
Log.err (fun k ->
|
||||
k "cannot decode json message: %s" (Printexc.to_string exn));
|
||||
IO.return (Error (E (ErrorCode.ParseError, "cannot decode json"))))
|
||||
| exception _ ->
|
||||
IO.return
|
||||
|
|
@ -150,72 +304,12 @@ module Make (IO : IO) : S with module IO = IO = struct
|
|||
let run ?(shutdown = fun _ -> false) (self : t) : unit IO.t =
|
||||
let process_msg r =
|
||||
let module M = Jsonrpc.Packet in
|
||||
let protect ~id f =
|
||||
IO.catch f (fun e ->
|
||||
let message =
|
||||
spf "%s\n%s" (Printexc.to_string e) (Printexc.get_backtrace ())
|
||||
in
|
||||
Log.err (fun k -> k "error: %s" message);
|
||||
let r =
|
||||
Jsonrpc.Response.error id
|
||||
(Jsonrpc.Response.Error.make
|
||||
~code:Jsonrpc.Response.Error.Code.InternalError ~message ())
|
||||
in
|
||||
send_response self r)
|
||||
in
|
||||
match r with
|
||||
| M.Notification n ->
|
||||
(* notification *)
|
||||
(match Lsp.Client_notification.of_jsonrpc n with
|
||||
| Ok n ->
|
||||
IO.catch
|
||||
(fun () ->
|
||||
self.s#on_notification n ~notify_back:(fun n ->
|
||||
let msg = Lsp.Server_notification.to_jsonrpc n in
|
||||
send_server_notif self msg))
|
||||
(fun e ->
|
||||
let msg =
|
||||
Lsp.Types.LogMessageParams.create
|
||||
~type_:Lsp.Types.MessageType.Error
|
||||
~message:(Printexc.to_string e)
|
||||
in
|
||||
let msg =
|
||||
Lsp.Server_notification.LogMessage msg
|
||||
|> Lsp.Server_notification.to_jsonrpc
|
||||
in
|
||||
send_server_notif self msg)
|
||||
| Error e -> IO.failwith (spf "cannot decode notification: %s" e))
|
||||
| M.Request r ->
|
||||
(* request, so we need to reply *)
|
||||
let id = r.id in
|
||||
IO.catch
|
||||
(fun () ->
|
||||
match Lsp.Client_request.of_jsonrpc r with
|
||||
| Ok (Lsp.Client_request.E r) ->
|
||||
protect ~id (fun () ->
|
||||
let* reply =
|
||||
self.s#on_request r ~id ~notify_back:(fun n ->
|
||||
let msg = Lsp.Server_notification.to_jsonrpc n in
|
||||
send_server_notif self msg)
|
||||
in
|
||||
let reply_json =
|
||||
Lsp.Client_request.yojson_of_result r reply
|
||||
in
|
||||
let response = Jsonrpc.Response.ok id reply_json in
|
||||
send_response self response)
|
||||
| Error e -> IO.failwith (spf "cannot decode request: %s" e))
|
||||
(fun e ->
|
||||
let message =
|
||||
spf "%s\n%s" (Printexc.to_string e) (Printexc.get_backtrace ())
|
||||
in
|
||||
Log.err (fun k -> k "error: %s" message);
|
||||
let r =
|
||||
Jsonrpc.Response.error id
|
||||
(Jsonrpc.Response.Error.make
|
||||
~code:Jsonrpc.Response.Error.Code.InternalError ~message ())
|
||||
in
|
||||
send_response self r)
|
||||
| _p -> IO.failwith "neither notification nor request"
|
||||
| M.Notification n -> handle_notification self n
|
||||
| M.Request r -> handle_request self r
|
||||
| M.Response r -> handle_response self r
|
||||
| M.Batch_response rs -> handle_batch_response self rs
|
||||
| M.Batch_call cs -> handle_batch_call self cs
|
||||
in
|
||||
let rec loop () =
|
||||
if shutdown () then
|
||||
|
|
|
|||
|
|
@ -29,17 +29,32 @@ module Make (IO : IO) = struct
|
|||
module DiagnosticSeverity = DiagnosticSeverity
|
||||
module Req_id = Req_id
|
||||
|
||||
(** A variant carrying a [Lsp.Server_request.t] and a handler for its return
|
||||
value. The request is stored in order to allow us to discriminate its
|
||||
existential variable. *)
|
||||
type server_request_handler_pair =
|
||||
| Request_and_handler :
|
||||
'from_server Lsp.Server_request.t
|
||||
* (('from_server, Jsonrpc.Response.Error.t) result -> unit IO.t)
|
||||
-> server_request_handler_pair
|
||||
|
||||
type send_request = server_request_handler_pair -> Req_id.t IO.t
|
||||
(** The type of the action that sends a request from the server to the client
|
||||
and handles its response. *)
|
||||
|
||||
(** The server baseclass *)
|
||||
class virtual base_server =
|
||||
object
|
||||
method virtual on_notification
|
||||
: notify_back:(Lsp.Server_notification.t -> unit IO.t) ->
|
||||
server_request:send_request ->
|
||||
Lsp.Client_notification.t ->
|
||||
unit IO.t
|
||||
|
||||
method virtual on_request
|
||||
: 'a.
|
||||
notify_back:(Lsp.Server_notification.t -> unit IO.t) ->
|
||||
server_request:send_request ->
|
||||
id:Req_id.t ->
|
||||
'a Lsp.Client_request.t ->
|
||||
'a IO.t
|
||||
|
|
@ -53,8 +68,8 @@ module Make (IO : IO) = struct
|
|||
end
|
||||
|
||||
(** A wrapper to more easily reply to notifications *)
|
||||
class notify_back ~notify_back ~workDoneToken ~partialResultToken:_ ?version
|
||||
?(uri : DocumentUri.t option) () =
|
||||
class notify_back ~notify_back ~server_request ~workDoneToken
|
||||
~partialResultToken:_ ?version ?(uri : DocumentUri.t option) () =
|
||||
object
|
||||
val mutable uri = uri
|
||||
method set_uri u = uri <- Some u
|
||||
|
|
@ -109,7 +124,15 @@ module Make (IO : IO) = struct
|
|||
| None -> IO.return ()
|
||||
|
||||
method send_notification (n : Lsp.Server_notification.t) = notify_back n
|
||||
(** Send a notification (general purpose method) *)
|
||||
(** Send a notification from the server to the client (general purpose method) *)
|
||||
|
||||
method send_request
|
||||
: 'from_server.
|
||||
'from_server Lsp.Server_request.t ->
|
||||
(('from_server, Jsonrpc.Response.Error.t) result -> unit IO.t) ->
|
||||
Req_id.t IO.t =
|
||||
fun r h -> server_request @@ Request_and_handler (r, h)
|
||||
(** Send a request from the server to the client (general purpose method) *)
|
||||
end
|
||||
|
||||
type nonrec doc_state = doc_state = {
|
||||
|
|
@ -271,8 +294,12 @@ module Make (IO : IO) = struct
|
|||
@since 0.3 *)
|
||||
|
||||
method on_request : type r.
|
||||
notify_back:_ -> id:Req_id.t -> r Lsp.Client_request.t -> r IO.t =
|
||||
fun ~notify_back ~id (r : _ Lsp.Client_request.t) ->
|
||||
notify_back:_ ->
|
||||
server_request:_ ->
|
||||
id:Req_id.t ->
|
||||
r Lsp.Client_request.t ->
|
||||
r IO.t =
|
||||
fun ~notify_back ~server_request ~id (r : _ Lsp.Client_request.t) ->
|
||||
Log.debug (fun k ->
|
||||
k "handle request[id=%s] <opaque>" (Req_id.to_string id));
|
||||
|
||||
|
|
@ -286,7 +313,7 @@ module Make (IO : IO) = struct
|
|||
let notify_back =
|
||||
new notify_back
|
||||
~partialResultToken:None ~workDoneToken:i.workDoneToken
|
||||
~notify_back ()
|
||||
~notify_back ~server_request ()
|
||||
in
|
||||
self#on_req_initialize ~notify_back i
|
||||
| Lsp.Client_request.TextDocumentHover
|
||||
|
|
@ -299,7 +326,8 @@ module Make (IO : IO) = struct
|
|||
| Some doc_st ->
|
||||
let notify_back =
|
||||
new notify_back
|
||||
~workDoneToken ~partialResultToken:None ~uri ~notify_back ()
|
||||
~workDoneToken ~partialResultToken:None ~uri ~notify_back
|
||||
~server_request ()
|
||||
in
|
||||
self#on_req_hover ~notify_back ~id ~uri ~pos:position
|
||||
~workDoneToken doc_st)
|
||||
|
|
@ -319,7 +347,8 @@ module Make (IO : IO) = struct
|
|||
| Some doc_st ->
|
||||
let notify_back =
|
||||
new notify_back
|
||||
~partialResultToken ~workDoneToken ~uri ~notify_back ()
|
||||
~partialResultToken ~workDoneToken ~uri ~notify_back
|
||||
~server_request ()
|
||||
in
|
||||
self#on_req_completion ~notify_back ~id ~uri ~workDoneToken
|
||||
~partialResultToken ~pos:position ~ctx:context doc_st)
|
||||
|
|
@ -330,7 +359,8 @@ module Make (IO : IO) = struct
|
|||
k "req: definition '%s'" (DocumentUri.to_path uri));
|
||||
let notify_back =
|
||||
new notify_back
|
||||
~workDoneToken ~partialResultToken ~uri ~notify_back ()
|
||||
~workDoneToken ~partialResultToken ~uri ~notify_back
|
||||
~server_request ()
|
||||
in
|
||||
|
||||
(match Hashtbl.find_opt docs uri with
|
||||
|
|
@ -345,7 +375,8 @@ module Make (IO : IO) = struct
|
|||
k "req: codelens '%s'" (DocumentUri.to_path uri));
|
||||
let notify_back =
|
||||
new notify_back
|
||||
~workDoneToken ~partialResultToken ~uri ~notify_back ()
|
||||
~workDoneToken ~partialResultToken ~uri ~notify_back
|
||||
~server_request ()
|
||||
in
|
||||
|
||||
(match Hashtbl.find_opt docs uri with
|
||||
|
|
@ -357,7 +388,8 @@ module Make (IO : IO) = struct
|
|||
Log.debug (fun k -> k "req: codelens resolve");
|
||||
let notify_back =
|
||||
new notify_back
|
||||
~workDoneToken:None ~partialResultToken:None ~notify_back ()
|
||||
~workDoneToken:None ~partialResultToken:None ~notify_back
|
||||
~server_request ()
|
||||
in
|
||||
self#on_req_code_lens_resolve ~notify_back ~id cl
|
||||
| Lsp.Client_request.ExecuteCommand
|
||||
|
|
@ -365,14 +397,17 @@ module Make (IO : IO) = struct
|
|||
Log.debug (fun k -> k "req: execute command '%s'" command);
|
||||
let notify_back =
|
||||
new notify_back
|
||||
~workDoneToken ~partialResultToken:None ~notify_back ()
|
||||
~workDoneToken ~partialResultToken:None ~notify_back
|
||||
~server_request ()
|
||||
in
|
||||
self#on_req_execute_command ~notify_back ~id ~workDoneToken command
|
||||
arguments
|
||||
| Lsp.Client_request.DocumentSymbol
|
||||
{ textDocument = d; workDoneToken; partialResultToken } ->
|
||||
let notify_back =
|
||||
new notify_back ~workDoneToken ~partialResultToken ~notify_back ()
|
||||
new notify_back
|
||||
~workDoneToken ~partialResultToken ~notify_back ~server_request
|
||||
()
|
||||
in
|
||||
self#on_req_symbol ~notify_back ~id ~uri:d.uri ~workDoneToken
|
||||
~partialResultToken ()
|
||||
|
|
@ -380,7 +415,8 @@ module Make (IO : IO) = struct
|
|||
let notify_back =
|
||||
new notify_back
|
||||
~workDoneToken:a.workDoneToken
|
||||
~partialResultToken:a.partialResultToken ~notify_back ()
|
||||
~partialResultToken:a.partialResultToken ~notify_back
|
||||
~server_request ()
|
||||
in
|
||||
self#on_req_code_action ~notify_back ~id a
|
||||
| Lsp.Client_request.CodeActionResolve _
|
||||
|
|
@ -420,7 +456,8 @@ module Make (IO : IO) = struct
|
|||
| Lsp.Client_request.UnknownRequest _ ->
|
||||
let notify_back =
|
||||
new notify_back
|
||||
~workDoneToken:None ~partialResultToken:None ~notify_back ()
|
||||
~workDoneToken:None ~partialResultToken:None ~notify_back
|
||||
~server_request ()
|
||||
in
|
||||
self#on_request_unhandled ~notify_back ~id r
|
||||
|
||||
|
|
@ -448,8 +485,8 @@ module Make (IO : IO) = struct
|
|||
IO.return ()
|
||||
(** Override to handle unprocessed notifications *)
|
||||
|
||||
method on_notification ~notify_back (n : Lsp.Client_notification.t)
|
||||
: unit IO.t =
|
||||
method on_notification ~notify_back ~server_request
|
||||
(n : Lsp.Client_notification.t) : unit IO.t =
|
||||
let open Lsp.Types in
|
||||
match n with
|
||||
| Lsp.Client_notification.TextDocumentDidOpen
|
||||
|
|
@ -459,7 +496,7 @@ module Make (IO : IO) = struct
|
|||
let notify_back =
|
||||
new notify_back
|
||||
~uri:doc.uri ~workDoneToken:None ~partialResultToken:None
|
||||
~version:doc.version ~notify_back ()
|
||||
~version:doc.version ~notify_back ~server_request ()
|
||||
in
|
||||
let st =
|
||||
{
|
||||
|
|
@ -479,7 +516,7 @@ module Make (IO : IO) = struct
|
|||
let notify_back =
|
||||
new notify_back
|
||||
~workDoneToken:None ~partialResultToken:None ~uri:doc.uri
|
||||
~notify_back ()
|
||||
~notify_back ~server_request ()
|
||||
in
|
||||
self#on_notif_doc_did_close
|
||||
~notify_back:(notify_back : notify_back)
|
||||
|
|
@ -491,7 +528,7 @@ module Make (IO : IO) = struct
|
|||
let notify_back =
|
||||
new notify_back
|
||||
~workDoneToken:None ~partialResultToken:None ~uri:doc.uri
|
||||
~notify_back ()
|
||||
~notify_back ~server_request ()
|
||||
in
|
||||
|
||||
let old_doc =
|
||||
|
|
@ -557,7 +594,8 @@ module Make (IO : IO) = struct
|
|||
| Lsp.Client_notification.LogTrace _ ->
|
||||
let notify_back =
|
||||
new notify_back
|
||||
~workDoneToken:None ~partialResultToken:None ~notify_back ()
|
||||
~workDoneToken:None ~partialResultToken:None ~notify_back
|
||||
~server_request ()
|
||||
in
|
||||
self#on_notification_unhandled
|
||||
~notify_back:(notify_back : notify_back)
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue