simon/linol
1
0
Fork 0
mirror of https://github.com/c-cube/linol.git synced 2025-12-05 19:00:34 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

move to lsp 1.14

Browse source
This commit is contained in:
Simon Cruanes 2023-03-10 23:12:13 -05:00
parent db3fde45f3
commit 8cbe2b3519
No known key found for this signature in database
GPG key ID: EBFFF6F283F3A2B4
3 changed files with 122 additions and 122 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
linol.opam
View file

@ -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 }
]

143
src/jsonrpc2.ml
View file

@ -1,4 +1,3 @@
(** {1 Simple JSON-RPC2 implementation}
See {{: https://www.jsonrpc.org/specification} the spec} *)
@ -17,25 +16,17 @@ module type S = sig
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)
open IO
@ -72,17 +63,14 @@ module Make(IO : IO)
}
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_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 json = J.to_string j in
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
@ -90,44 +78,47 @@ module Make(IO : IO)
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
(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))
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
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
@ -137,58 +128,55 @@ module Make(IO : IO)
| 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
(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")))
end
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 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
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
let r =
Jsonrpc.Response.error id
(Jsonrpc.Response.Error.make
~code:Jsonrpc.Response.Error.Code.InternalError
~message ())
~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
(match Lsp.Client_notification.of_jsonrpc n with
| Ok n ->
IO.catch
(fun () ->
(self.s)#on_notification n
~notify_back:(fun n ->
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
Lsp.Types.LogMessageParams.create
~type_:Lsp.Types.MessageType.Error
~message:(Printexc.to_string e)
in
let msg =
@ -196,50 +184,49 @@ module Make(IO : IO)
|> Lsp.Server_notification.to_jsonrpc
in
send_server_notif self msg)
| Error e ->
IO.failwith (spf "cannot decode notification: %s" e)
end
| Some id ->
| 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
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* 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
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 ())
~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 ()
| Error e -> IO.fail e
)
in
loop ()
end

13
src/server.ml
View file

@ -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