Skip to content

Commit

Permalink
Use same life-cycle as dune rpc
Browse files Browse the repository at this point in the history
  • Loading branch information
@voodoos
voodoos committed Jun 29, 2021
1 parent 5a79b4d commit 42b0971
Show file tree
Hide file tree
Showing 3 changed files with 128 additions and 130 deletions.
90 changes: 48 additions & 42 deletions ocaml-lsp-server/src/ocaml_lsp_server.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -986,48 +986,54 @@ let start () =
(fun () -> Fiber.Pool.run detached)
(fun () ->
let* () =
Fiber.fork_and_join_unit
(fun () -> Server.start server)
(fun () ->
let* (init_params : InitializeParams.t) =
Server.initialized server
in
let progress =
Progress.create init_params.capabilities
~report_progress:(fun progress ->
Server.notification server
(Server_notification.WorkDoneProgress progress))
~create_task:(fun task ->
Server.request server
(Server_request.WorkDoneProgressCreate task))
in
let dune =
let dune' = Dune.create diagnostics progress in
dune := Some dune';
dune'
in
let* state = Dune.run dune in
let message =
match state with
| Error Binary_not_found ->
Some "Dune must be installed for project functionality"
| Error Out_of_date ->
Some
"Dune is out of date. Install dune >= 3.0 for project \
functionality"
| Ok () -> None
in
match message with
| None -> Fiber.return ()
(* We disable the warnings because dune 3.0 isn't available yet *)
| Some _ when true -> Fiber.return ()
| Some message ->
let* (_ : InitializeParams.t) = Server.initialized server in
let state = Server.state server in
task_if_running state ~f:(fun () ->
let log = LogMessageParams.create ~type_:Warning ~message in
Server.notification server
(Server_notification.LogMessage log)))
Fiber.parallel_iter
~f:(fun f -> f ())
[ (fun () -> Server.start server)
; (fun () ->
let* _state = Ocamlformat_rpc.run ocamlformat_rpc in
(* TODO ulysse Handle errors*)
Fiber.return ())
; (fun () ->
let* (init_params : InitializeParams.t) =
Server.initialized server
in
let progress =
Progress.create init_params.capabilities
~report_progress:(fun progress ->
Server.notification server
(Server_notification.WorkDoneProgress progress))
~create_task:(fun task ->
Server.request server
(Server_request.WorkDoneProgressCreate task))
in
let dune =
let dune' = Dune.create diagnostics progress in
dune := Some dune';
dune'
in
let* state = Dune.run dune in
let message =
match state with
| Error Binary_not_found ->
Some "Dune must be installed for project functionality"
| Error Out_of_date ->
Some
"Dune is out of date. Install dune >= 3.0 for project \
functionality"
| Ok () -> None
in
match message with
| None -> Fiber.return ()
(* We disable the warnings because dune 3.0 isn't available yet *)
| Some _ when true -> Fiber.return ()
| Some message ->
let* (_ : InitializeParams.t) = Server.initialized server in
let state = Server.state server in
task_if_running state ~f:(fun () ->
let log = LogMessageParams.create ~type_:Warning ~message in
Server.notification server
(Server_notification.LogMessage log)))
]
in
let* () =
Fiber.parallel_iter
Expand Down
164 changes: 76 additions & 88 deletions ocaml-lsp-server/src/ocamlformat_rpc.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -2,6 +2,8 @@ open Import

type type_ = string

type run = Binary_not_found

type process =
{ pid : Pid.t
; input : in_channel
Expand All @@ -11,10 +13,9 @@ type process =
}

type state =
| Binary_not_found
| Stopped
| Waiting_for_init
| Running of process
| Errored

type t = state ref

Expand Down Expand Up @@ -56,95 +57,49 @@ let configure process =
[ ("msg", `String msg) ])
| Error e -> Exn_with_backtrace.reraise e)

let start_exn ?io_thread t =
let prog = "ocamlformat-rpc" in
match Bin.which prog with
| None ->
t := Binary_not_found;
Fiber.return @@ Error `No_process
| Some bin_path -> (
let bin = Fpath.to_string bin_path in
let argv = [| bin |] in
let pid, stdout, stdin =
let stdin_i, stdin_o = Unix.pipe () in
let stdout_i, stdout_o = Unix.pipe () in
let pid = Unix.create_process bin argv stdin_i stdout_o Unix.stderr in
(pid, stdout_i, stdin_o)
in
let open Fiber.O in
let input = Unix.in_channel_of_descr stdout in
let output = Unix.out_channel_of_descr stdin in
let* io_thread =
(* Don't create a new thread if there is already one. *)
(* This can happen if the Ocamlformat server crashed. *)
match io_thread with
| Some io_thread -> Fiber.return io_thread
| None -> Scheduler.create_thread ()
in
let* client = pick_client ~pid input output io_thread in
match client with
| Error (`Msg msg) ->
(* The process did start but something went wrong when negociating the
version so we need to kill it *)
Unix.kill pid Sys.sigkill;
Scheduler.stop io_thread;
Fiber.return @@ Error (`Msg msg)
| Ok client ->
let process =
{ pid = Pid.of_int pid; input; output; io_thread; client }
in
let+ () = configure process in
Log.log ~section:"ocamlformat" (fun () ->
Log.msg "Ocamlformat-RPC server started" [ ("pid", `Int pid) ]);
t := Running process;
Ok process)

let start ?io_thread t =
let start ~bin () =
let bin = Fpath.to_string bin in
let argv = [| bin |] in
let pid, stdout, stdin =
let stdin_i, stdin_o = Unix.pipe () in
let stdout_i, stdout_o = Unix.pipe () in
let pid = Unix.create_process bin argv stdin_i stdout_o Unix.stderr in
(pid, stdout_i, stdin_o)
in
let open Fiber.O in
try
let+ result = start_exn ?io_thread t in
match result with
| Error (`Msg msg) ->
Log.log ~section:"ocamlformat" (fun () ->
Log.msg "An error occured while initializing ocamlformat"
[ ("msg", `String msg) ]);
Error `No_process
| r -> r
with
| Unix.Unix_error (e, _, _) ->
t := Errored;
let* io_thread = Scheduler.create_thread () in
let input = Unix.in_channel_of_descr stdout in
let output = Unix.out_channel_of_descr stdin in
let* client = pick_client ~pid input output io_thread in
match client with
| Error (`Msg msg) ->
(* The process did start but something went wrong when negociating the
version so we need to kill it *)
Unix.kill pid Sys.sigkill;
Scheduler.stop io_thread;
Fiber.return @@ Error (`Msg msg)
| Ok client ->
let process = { pid = Pid.of_int pid; input; output; io_thread; client } in
let+ () = configure process in
Log.log ~section:"ocamlformat" (fun () ->
Log.msg "An error occured when starting ocamlformat"
[ ("msg", `String (Unix.error_message e)) ]);
Fiber.return @@ Error `No_process
Log.msg "Ocamlformat-RPC server started" [ ("pid", `Int pid) ]);
Ok process

let get_process t =
let process_run process =
let open Fiber.O in
let+ (_ : Unix.process_status) = Scheduler.wait_for_process process.pid in
Scheduler.stop process.io_thread

let get_process t =
match !t with
| Stopped -> start t
| Running ({ pid; io_thread; _ } as p) -> (
let pid = Pid.to_int pid in
(* Is the process still running ? *)
match
Scheduler.async io_thread (fun () -> Unix.waitpid [ WNOHANG ] pid |> fst)
with
| Error `Stopped -> Fiber.return @@ Error (`Msg "Thread stopped")
| Ok res -> (
let* res = Scheduler.await_no_cancel res in
match res with
| Error e -> Exn_with_backtrace.reraise e
| Ok 0 -> Fiber.return @@ Ok p
| Ok _ ->
Log.log ~section:"ocamlformat" (fun () ->
Log.msg "Ocamlformat-RPC server exited" [ ("pid", `Int pid) ]);
start ~io_thread t))
| Errored
| Binary_not_found ->
Fiber.return @@ Error `No_process
| Running p -> Ok p
| Stopped
| Waiting_for_init ->
Error `No_process

let query_type t typ =
let open Fiber.O in
let* p = get_process t in
let p = get_process t in
match p with
| Error `No_process -> Fiber.return @@ Error (`Msg "No process")
| Error (`Msg msg) -> Fiber.return @@ Error (`Msg msg)
Expand All @@ -160,16 +115,49 @@ let query_type t typ =
| Ok s -> s
| Error e -> Exn_with_backtrace.reraise e))

let create () = ref Stopped
let create () = ref Waiting_for_init

let stop t =
match !t with
| Binary_not_found
| Stopped
| Errored ->
| Stopped -> Fiber.return ()
| Waiting_for_init ->
t := Stopped;
Fiber.return ()
| Running { pid; _ } ->
let pid = Pid.to_int pid in
t := Stopped;
Unix.kill pid Sys.sigkill;
Unix.kill pid Sys.sigstop;
Fiber.return ()

let run_rpc ~bin t =
let open Fiber.O in
match !t with
| Stopped -> Code_error.raise "ocamlformat already stopped" []
| Running _ -> Code_error.raise "ocamlformat alrady running" []
| Waiting_for_init -> (
(* let finish = Fiber.Ivar.create () in *)
let* process = start ~bin () in
match process with
| Error _ ->
t := Stopped;
Fiber.return ()
| Ok process ->
t := Running process;
let+ () = process_run process in
t := Waiting_for_init)

let run t =
let open Fiber.O in
match Bin.which "ocamlformat-rpc" with
| None -> Fiber.return (Error Binary_not_found)
| Some bin ->
let rec loop () =
match !t with
| Stopped -> Fiber.return (Ok ())
| Waiting_for_init ->
let* () = run_rpc ~bin t in
(* We loop to automatically restart the server if it stopped *)
loop ()
| Running _ -> assert false
in
loop ()
4 changes: 4 additions & 0 deletions ocaml-lsp-server/src/ocamlformat_rpc.mli
View file
Original file line number Diff line number Diff line change
Expand Up @@ -7,3 +7,7 @@ val create : unit -> t
val stop : t -> unit Fiber.t

val query_type : t -> type_ -> (type_, [> `Msg of string ]) result Fiber.t

type run = Binary_not_found

val run : t -> (unit, run) result Fiber.t

0 comments on commit 42b0971

Please sign in to comment.