From 8cbe2b35194611b13f9da474ab05576c62f54e49 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 10 Mar 2023 23:12:13 -0500 Subject: [PATCH] move to lsp 1.14 --- linol.opam | 2 +- src/jsonrpc2.ml | 229 +++++++++++++++++++++++------------------------- src/server.ml | 13 +++ 3 files changed, 122 insertions(+), 122 deletions(-) diff --git a/linol.opam b/linol.opam index 1211e0cf..45c66c83 100644 --- a/linol.opam +++ b/linol.opam @@ -14,7 +14,7 @@ depends: [ "dune" { >= "2.0" } "yojson" { >= "1.6" } "logs" - "lsp" { >= "1.11" & < "1.12" } + "lsp" { >= "1.14" & < "1.15" } "ocaml" { >= "4.12" } "odoc" { with-doc } ] diff --git a/src/jsonrpc2.ml b/src/jsonrpc2.ml index d730aea1..b276a198 100644 --- a/src/jsonrpc2.ml +++ b/src/jsonrpc2.ml @@ -1,4 +1,3 @@ - (** {1 Simple JSON-RPC2 implementation} See {{: https://www.jsonrpc.org/specification} the spec} *) @@ -15,29 +14,21 @@ module type S = sig type t (** A jsonrpc2 connection. *) - include module type of Server.Make(IO) + include module type of Server.Make (IO) - val create : - ic:IO.in_channel -> - oc:IO.out_channel -> - server -> - t + val create : ic:IO.in_channel -> oc:IO.out_channel -> server -> t (** Create a connection from the pair of channels *) val create_stdio : server -> t (** Create a connection using stdin/stdout *) - val run : - ?shutdown:(unit -> bool) -> - t -> unit IO.t + val run : ?shutdown:(unit -> bool) -> t -> unit IO.t (** Listen for incoming messages and responses *) end -module Make(IO : IO) - : S with module IO = IO -= struct +module Make (IO : IO) : S with module IO = IO = struct module IO = IO - include Server.Make(IO) + include Server.Make (IO) open IO type json = J.t @@ -71,63 +62,63 @@ module Make(IO : IO) s: server; } - let create ~ic ~oc server : t = {ic; oc; s=server} - - let create_stdio server : t = - create ~ic:IO.stdin ~oc:IO.stdout server + let create ~ic ~oc server : t = { ic; oc; s = server } + let create_stdio server : t = create ~ic:IO.stdin ~oc:IO.stdout server (* send a single message *) - let send_json_ (self:t) (j:json) : unit IO.t = + let send_json_ (self : t) (j : json) : unit IO.t = let json = J.to_string j in - Log.debug (fun k->k "jsonrpc2: send json: %s" json); + Log.debug (fun k -> k "jsonrpc2: send json: %s" json); let full_s = - Printf.sprintf "Content-Length: %d\r\n\r\n%s" - (String.length json) json + Printf.sprintf "Content-Length: %d\r\n\r\n%s" (String.length json) json in IO.write_string self.oc full_s - let send_response (self:t) (m:Jsonrpc.Response.t) : unit IO.t = + let send_response (self : t) (m : Jsonrpc.Response.t) : unit IO.t = let json = Jsonrpc.Response.yojson_of_t m in send_json_ self json - let send_server_notif (self:t) (m:Jsonrpc.Message.notification) : unit IO.t = - let json = Jsonrpc.Message.yojson_of_notification m in + let send_server_notif (self : t) (m : Jsonrpc.Notification.t) : unit IO.t = + let json = Jsonrpc.Notification.yojson_of_t m in send_json_ self json let try_ f = IO.catch - (fun () -> let+ x = f() in Ok x) + (fun () -> + let+ x = f () in + Ok x) (fun e -> IO.return (Error e)) (* read a full message *) - let read_msg (self:t) : (Jsonrpc.Message.either, exn) result IO.t = + let read_msg (self : t) : (Jsonrpc.Packet.t, exn) result IO.t = let rec read_headers acc = - let*? line = - try_ @@ fun () -> IO.read_line self.ic - in + let*? line = try_ @@ fun () -> IO.read_line self.ic in match String.trim line with | "" -> IO.return (Ok acc) (* last separator *) | line -> - begin match - let i = String.index line ':' in - if i<0 || String.get line (i+1) <> ' ' then raise Not_found; - let key = String.lowercase_ascii @@ String.sub line 0 i in - let v = - String.lowercase_ascii @@ - String.trim (String.sub line (i+1) (String.length line-i-1)) - in - key, v - with - | pair -> read_headers (pair :: acc) - | exception _ -> - IO.return (Error (E(ErrorCode.ParseError, spf "invalid header: %S" line))) - end + (match + let i = String.index line ':' in + if i < 0 || String.get line (i + 1) <> ' ' then raise Not_found; + let key = String.lowercase_ascii @@ String.sub line 0 i in + let v = + String.lowercase_ascii + @@ String.trim + (String.sub line (i + 1) (String.length line - i - 1)) + in + key, v + with + | pair -> read_headers (pair :: acc) + | exception _ -> + IO.return + (Error (E (ErrorCode.ParseError, spf "invalid header: %S" line)))) in let*? headers = read_headers [] in - Log.debug (fun k->k "jsonrpc2: read headers: [%s]" - (String.concat ";" @@ - List.map (fun (a,b)->Printf.sprintf "(%S,%S)" a b) headers)); - let ok = match List.assoc "content-type" headers with + Log.debug (fun k -> + k "jsonrpc2: read headers: [%s]" + (String.concat ";" + @@ List.map (fun (a, b) -> Printf.sprintf "(%S,%S)" a b) headers)); + let ok = + match List.assoc "content-type" headers with | "utf8" | "utf-8" -> true | _ -> false | exception Not_found -> true @@ -135,111 +126,107 @@ module Make(IO : IO) if ok then ( match int_of_string (List.assoc "content-length" headers) with | n -> - Log.debug (fun k->k "jsonrpc2: read %d bytes..." n); + Log.debug (fun k -> k "jsonrpc2: read %d bytes..." n); let buf = Bytes.make n '\000' in - let*? () = - try_ @@ fun () -> IO.read self.ic buf 0 n - in + let*? () = try_ @@ fun () -> IO.read self.ic buf 0 n in (* log_lsp_ "got bytes %S" (Bytes.unsafe_to_string buf); *) let*? j = try_ @@ fun () -> IO.return @@ J.from_string (Bytes.unsafe_to_string buf) in - Log.debug (fun k->k "got json %s" (J.to_string j)); - begin match Jsonrpc.Message.either_of_yojson j with - | m -> IO.return @@ Ok m - | exception _ -> - Log.err (fun k->k "cannot decode json message"); - IO.return (Error (E(ErrorCode.ParseError, "cannot decode json"))) - end + 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"); + IO.return (Error (E (ErrorCode.ParseError, "cannot decode json")))) | exception _ -> - IO.return @@ - Error (E(ErrorCode.ParseError, "missing content-length' header")) - ) else ( - IO.return @@ - Error (E(ErrorCode.InvalidRequest, "content-type must be 'utf-8'")) - ) + IO.return + @@ Error (E (ErrorCode.ParseError, "missing content-length' header")) + ) else + IO.return + @@ Error (E (ErrorCode.InvalidRequest, "content-type must be 'utf-8'")) - let run ?(shutdown=fun _ -> false) (self:t) : unit IO.t = + let run ?(shutdown = fun _ -> false) (self : t) : unit IO.t = let process_msg r = - let module M = Jsonrpc.Message in + 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 ()) + 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.M.id with - | None -> + match r with + | M.Notification n -> (* notification *) - begin match Lsp.Client_notification.of_jsonrpc {r with M.id=()} 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) - end - | Some id -> + (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 () -> - begin match Lsp.Client_request.of_jsonrpc {r with M.id} with - | Ok (Lsp.Client_request.E r) -> - protect ~id (fun () -> - let* reply = self.s#on_request r ~id - ~notify_back:(fun n -> + 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 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) - end) + 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 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 ()) + (Jsonrpc.Response.Error.make + ~code:Jsonrpc.Response.Error.Code.InternalError ~message ()) in send_response self r) + | _p -> IO.failwith "neither notification nor request" in let rec loop () = - if shutdown() then IO.return () - else ( + if shutdown () then + IO.return () + else let* r = read_msg self in match r with | Ok r -> IO.spawn (fun () -> process_msg r); - loop() + loop () | Error e -> IO.fail e - ) in - loop() + loop () end - diff --git a/src/server.ml b/src/server.ml index 52d541bd..3a300f3c 100644 --- a/src/server.ml +++ b/src/server.ml @@ -330,6 +330,14 @@ module Make(IO : IO) = struct | Lsp.Client_request.SemanticTokensDelta _ | Lsp.Client_request.SemanticTokensFull _ | Lsp.Client_request.SemanticTokensRange _ + | Lsp.Client_request.TextDocumentImplementation _ + | Lsp.Client_request.TextDocumentPrepareCallHierarchy _ + | Lsp.Client_request.TextDocumentRangeFormatting _ + | Lsp.Client_request.CallHierarchyIncomingCalls _ + | Lsp.Client_request.CallHierarchyOutgoingCalls _ + | Lsp.Client_request.WillCreateFiles _ + | Lsp.Client_request.WillDeleteFiles _ + | Lsp.Client_request.WillRenameFiles _ | Lsp.Client_request.UnknownRequest _ -> let notify_back = new notify_back ~notify_back () in self#on_request_unhandled ~notify_back ~id r @@ -435,6 +443,11 @@ module Make(IO : IO) = struct | Lsp.Client_notification.CancelRequest _ | Lsp.Client_notification.WorkDoneProgressCancel _ | Lsp.Client_notification.SetTrace _ + | Lsp.Client_notification.DidChangeWatchedFiles _ + | Lsp.Client_notification.DidCreateFiles _ + | Lsp.Client_notification.DidDeleteFiles _ + | Lsp.Client_notification.DidRenameFiles _ + | Lsp.Client_notification.LogTrace _ -> let notify_back = new notify_back ~notify_back () in self#on_notification_unhandled ~notify_back n