unikernel/duniverse/dune_/bin/rpc/rpc.ml

@@ -0,0 +1,16 @@
+open Import
+
+let info =
+  let doc = "Dune's RPC mechanism. Experimental." in
+  let man =
+    [ `S "DESCRIPTION"
+    ; `P {|This is experimental. do not use|}
+    ; `Blocks Common.help_secs
+    ]
+  in
+  Cmd.info "rpc" ~doc ~man
+;;
+
+let group = Cmd.group info [ Rpc_status.cmd; Rpc_build.cmd; Rpc_ping.cmd ]
+
+module Build = Rpc_build

unikernel/duniverse/dune_/bin/rpc/rpc.mli

@@ -0,0 +1,4 @@
+(** dune rpc command group *)
+val group : unit Cmdliner.Cmd.t
+
+module Build = Rpc_build

unikernel/duniverse/dune_/bin/rpc/rpc_build.ml

@@ -0,0 +1,37 @@
+open Import
+
+let build ~wait targets =
+  let targets =
+    List.map targets ~f:(fun target ->
+      let sexp = Dune_lang.Dep_conf.encode target in
+      Dune_lang.to_string sexp)
+  in
+  Rpc_common.fire_request ~name:"build" ~wait Dune_rpc_impl.Decl.build targets
+;;
+
+let term =
+  let name_ = Arg.info [] ~docv:"TARGET" in
+  let+ (builder : Common.Builder.t) = Common.Builder.term
+  and+ wait = Rpc_common.wait_term
+  and+ targets = Arg.(value & pos_all string [] name_) in
+  Rpc_common.client_term builder
+  @@ fun () ->
+  let open Fiber.O in
+  let+ response =
+    Rpc_common.fire_request ~name:"build" ~wait Dune_rpc_impl.Decl.build targets
+  in
+  match response with
+  | Error (error : Dune_rpc.Response.Error.t) ->
+    Printf.eprintf "Error: %s\n%!" (Dyn.to_string (Dune_rpc.Response.Error.to_dyn error))
+  | Ok Success -> print_endline "Success"
+  | Ok (Failure _) -> print_endline "Failure"
+;;
+
+let info =
+  let doc =
+    "build a given target (requires dune to be running in passive watching mode)"
+  in
+  Cmd.info "build" ~doc
+;;
+
+let cmd = Cmd.v info term

unikernel/duniverse/dune_/bin/rpc/rpc_build.mli

@@ -0,0 +1,13 @@
+open! Import
+
+(** Sends a command to an RPC server to build the specified targets and wait
+    for the build to complete or fail. If [wait] is true then wait until an RPC
+    server is running before making the request. Otherwise if no RPC server is
+    running then raise a [User_error].  *)
+val build
+  :  wait:bool
+  -> Dune_lang.Dep_conf.t list
+  -> (Dune_rpc.Build_outcome_with_diagnostics.t, Dune_rpc.Response.Error.t) result Fiber.t
+
+(** dune rpc build command *)
+val cmd : unit Cmdliner.Cmd.t

unikernel/duniverse/dune_/bin/rpc/rpc_common.ml

@@ -0,0 +1,125 @@
+open Import
+module Client = Dune_rpc_client.Client
+module Rpc_error = Dune_rpc.Response.Error
+
+let active_server () =
+  match Dune_rpc_impl.Where.get () with
+  | Some p -> Ok p
+  | None -> Error (User_error.make [ Pp.text "RPC server not running." ])
+;;
+
+let active_server_exn () = active_server () |> User_error.ok_exn
+
+(* cwong: Should we put this into [dune-rpc]? *)
+let interpret_kind = function
+  | Rpc_error.Invalid_request -> "Invalid_request"
+  | Code_error -> "Code_error"
+  | Connection_dead -> "Connection_dead"
+;;
+
+let raise_rpc_error (e : Rpc_error.t) =
+  User_error.raise
+    [ Pp.text "Server returned error: "
+    ; Pp.textf "%s (error kind: %s)" e.message (interpret_kind e.kind)
+    ]
+;;
+
+let request_exn client witness n =
+  let open Fiber.O in
+  let* decl = Client.Versioned.prepare_request client witness in
+  match decl with
+  | Error e -> raise (Dune_rpc.Version_error.E e)
+  | Ok decl -> Client.request client decl n
+;;
+
+let client_term builder f =
+  let builder = Common.Builder.forbid_builds builder in
+  let builder = Common.Builder.disable_log_file builder in
+  let common, config = Common.init builder in
+  Scheduler.go_with_rpc_server ~common ~config f
+;;
+
+let wait_term =
+  let doc = "poll until server starts listening and then establish connection." in
+  Arg.(value & flag & info [ "wait" ] ~doc)
+;;
+
+let establish_connection () =
+  match active_server () with
+  | Error e -> Fiber.return (Error e)
+  | Ok where -> Client.Connection.connect where
+;;
+
+let establish_connection_exn () =
+  let open Fiber.O in
+  establish_connection () >>| User_error.ok_exn
+;;
+
+let establish_connection_with_retry () =
+  let open Fiber.O in
+  let pause_between_retries_s = 0.2 in
+  let rec loop () =
+    establish_connection ()
+    >>= function
+    | Ok x -> Fiber.return x
+    | Error _ ->
+      let* () = Scheduler.sleep ~seconds:pause_between_retries_s in
+      loop ()
+  in
+  loop ()
+;;
+
+let establish_client_session ~wait =
+  if wait then establish_connection_with_retry () else establish_connection_exn ()
+;;
+
+let fire_request ~name ~wait request arg =
+  let open Fiber.O in
+  let* connection = establish_client_session ~wait in
+  Dune_rpc_impl.Client.client
+    connection
+    (Dune_rpc.Initialize.Request.create ~id:(Dune_rpc.Id.make (Sexp.Atom name)))
+    ~f:(fun client -> request_exn client (Dune_rpc.Decl.Request.witness request) arg)
+;;
+
+let wrap_build_outcome_exn ~print_on_success f args () =
+  let open Fiber.O in
+  let+ response = f args in
+  match response with
+  | Error (error : Rpc_error.t) ->
+    Printf.eprintf "Error: %s\n%!" (Dyn.to_string (Rpc_error.to_dyn error))
+  | Ok Dune_rpc.Build_outcome_with_diagnostics.Success ->
+    if print_on_success
+    then
+      Console.print_user_message
+        (User_message.make [ Pp.text "Success" |> Pp.tag User_message.Style.Success ])
+  | Ok (Failure errors) ->
+    List.iter errors ~f:(fun { Dune_rpc.Compound_user_error.main; _ } ->
+      Console.print_user_message main);
+    User_error.raise
+      [ (match List.length errors with
+         | 0 ->
+           Code_error.raise
+             "Build via RPC failed, but the RPC server did not send an error message."
+             []
+         | 1 -> Pp.textf "Build failed with 1 error."
+         | n -> Pp.textf "Build failed with %d errors." n)
+      ]
+;;
+
+let run_via_rpc ~builder ~common ~config lock_held_by f args =
+  if not (Common.Builder.equal builder Common.Builder.default)
+  then
+    User_warning.emit
+      [ Pp.textf
+          "Your build request is being forwarded to a running Dune instance%s. Note that \
+           certain command line arguments may be ignored."
+          (match lock_held_by with
+           | Dune_util.Global_lock.Lock_held_by.Unknown -> ""
+           | Pid_from_lockfile pid -> sprintf " (pid: %d)" pid)
+      ];
+  Scheduler.go_without_rpc_server
+    ~common
+    ~config
+    (wrap_build_outcome_exn ~print_on_success:true f args)
+;;

unikernel/duniverse/dune_/bin/rpc/rpc_common.mli

@@ -0,0 +1,52 @@
+open Import
+
+(** The current active RPC server, raising an exception if no RPC server is
+    currently running. *)
+val active_server_exn : unit -> Dune_rpc.Where.t
+
+(** Raise an RPC response error. *)
+val raise_rpc_error : Dune_rpc.Response.Error.t -> 'a
+
+(** Make a request and raise an exception if the preparation for the request
+    fails in any way. Returns an [Error] if the response errors. *)
+val request_exn
+  :  Dune_rpc_client.Client.t
+  -> ('a, 'b) Dune_rpc.Decl.Request.witness
+  -> 'a
+  -> ('b, Dune_rpc.Response.Error.t) result Fiber.t
+
+(** Cmdliner term for a generic RPC client. *)
+val client_term : Common.Builder.t -> (unit -> 'a Fiber.t) -> 'a
+
+(** Cmdliner argument for a wait flag. *)
+val wait_term : bool Cmdliner.Term.t
+
+(** Send a request to the RPC server. If [wait], it will poll forever until a server is listening.
+    Should be scheduled by a scheduler that does not come with a RPC server on its own. *)
+val fire_request
+  :  name:string
+  -> wait:bool
+  -> ('a, 'b) Dune_rpc.Decl.request
+  -> 'a
+  -> ('b, Dune_rpc.Response.Error.t) result Fiber.t
+
+val wrap_build_outcome_exn
+  :  print_on_success:bool
+  -> ('a
+      -> (Dune_rpc.Build_outcome_with_diagnostics.t, Dune_rpc.Response.Error.t) result
+           Fiber.t)
+  -> 'a
+  -> unit
+  -> unit Fiber.t
+
+(**  Schedule a fiber to run via RPC, wrapping any errors. *)
+val run_via_rpc
+  :  builder:Common.Builder.t
+  -> common:Common.t
+  -> config:Dune_config_file.Dune_config.t
+  -> Dune_util.Global_lock.Lock_held_by.t
+  -> ('a
+      -> (Dune_rpc.Build_outcome_with_diagnostics.t, Dune_rpc.Response.Error.t) result
+           Fiber.t)
+  -> 'a
+  -> unit

unikernel/duniverse/dune_/bin/rpc/rpc_ping.ml

@@ -0,0 +1,33 @@
+open Import
+module Client = Dune_rpc_client.Client
+
+let send_ping cli =
+  let open Fiber.O in
+  let+ response = Rpc_common.request_exn cli Dune_rpc_private.Public.Request.ping () in
+  match response with
+  | Ok () -> Console.print [ Pp.text "Server appears to be responding normally" ]
+  | Error e -> Rpc_common.raise_rpc_error e
+;;
+
+let exec () =
+  let open Fiber.O in
+  let where = Rpc_common.active_server_exn () in
+  let* conn = Client.Connection.connect_exn where in
+  Dune_rpc_impl.Client.client
+    conn
+    ~f:send_ping
+    (Dune_rpc_private.Initialize.Request.create
+       ~id:(Dune_rpc_private.Id.make (Sexp.Atom "ping_cmd")))
+;;
+
+let info =
+  let doc = "Ping the build server running in the current directory" in
+  Cmd.info "ping" ~doc
+;;
+
+let term =
+  let+ (builder : Common.Builder.t) = Common.Builder.term in
+  Rpc_common.client_term builder exec
+;;
+
+let cmd = Cmd.v info term

unikernel/duniverse/dune_/bin/rpc/rpc_ping.mli

@@ -0,0 +1,2 @@
+(** dune rpc ping command *)
+val cmd : unit Cmdliner.Cmd.t

unikernel/duniverse/dune_/bin/rpc/rpc_status.ml

@@ -0,0 +1,146 @@
+open Import
+module Client = Dune_rpc_client.Client
+
+let ( let** ) x f =
+  let open Fiber.O in
+  let* x = x in
+  match x with
+  | Ok s -> f s
+  | Error e -> Fiber.return (Error e)
+;;
+
+let ( let++ ) x f =
+  let open Fiber.O in
+  let+ x = x in
+  match x with
+  | Ok s -> Ok (f s)
+  | Error e -> Error e
+;;
+
+(** Get the status of a server at a given location and apply a function to the
+    list of clients *)
+let server_response_map ~where ~f =
+  (* TODO: add timeout for status check *)
+  let open Fiber.O in
+  let** conn =
+    Client.Connection.connect where >>| Result.map_error ~f:User_message.to_string
+  in
+  Dune_rpc_impl.Client.client
+    conn
+    (Dune_rpc.Initialize.Request.create ~id:(Dune_rpc.Id.make (Sexp.Atom "status")))
+    ~f:(fun session ->
+      let open Fiber.O in
+      let++ response =
+        let** decl =
+          Client.Versioned.prepare_request
+            session
+            (Dune_rpc_private.Decl.Request.witness Dune_rpc_impl.Decl.status)
+          >>| Result.map_error ~f:Dune_rpc_private.Version_error.message
+        in
+        Client.request session decl ()
+        >>| Result.map_error ~f:Dune_rpc.Response.Error.message
+      in
+      f response.Dune_rpc_impl.Decl.Status.clients)
+;;
+
+(** Get a list of registered Dunes from the RPC registry *)
+let registered_dunes () : Dune_rpc.Registry.Dune.t list Fiber.t =
+  let config = Dune_rpc_private.Registry.Config.create (Lazy.force Dune_util.xdg) in
+  let registry = Dune_rpc_private.Registry.create config in
+  let open Fiber.O in
+  let+ _result = Dune_rpc_impl.Poll_active.poll registry in
+  Dune_rpc_private.Registry.current registry
+;;
+
+(** The type of server statuses *)
+type status =
+  { root : string
+  ; pid : Pid.t
+  ; result : (int, string) result
+  }
+
+(** Fetch the status of a single Dune instance *)
+let get_status (dune : Dune_rpc.Registry.Dune.t) =
+  let root = Dune_rpc_private.Registry.Dune.root dune in
+  let pid = Dune_rpc_private.Registry.Dune.pid dune |> Pid.of_int in
+  let where = Dune_rpc_private.Registry.Dune.where dune in
+  let open Fiber.O in
+  let+ result = server_response_map ~where ~f:List.length in
+  { root; pid; result }
+;;
+
+(** Print a list of statuses to the console *)
+let print_statuses statuses =
+  List.sort statuses ~compare:(fun x y -> String.compare x.root y.root)
+  |> Pp.concat_map ~sep:Pp.space ~f:(fun { root; pid; result } ->
+    Pp.concat
+      ~sep:Pp.space
+      [ Pp.textf "root: %s" root
+      ; Pp.enumerate
+          ~f:Fun.id
+          [ Pp.textf "pid: %d" (Pid.to_int pid)
+          ; Pp.textf
+              "clients: %s"
+              (match result with
+               | Ok n -> string_of_int n
+               | Error e -> e)
+          ]
+      ])
+  |> Pp.vbox
+  |> List.singleton
+  |> Console.print
+;;
+
+let term =
+  let+ builder = Common.Builder.term
+  and+ all =
+    Arg.(
+      value
+      & flag
+      & info
+          [ "all" ]
+          ~doc:
+            "Show all running Dune instances together with their root, pids and number \
+             of clients.")
+  in
+  Rpc_common.client_term builder
+  @@ fun () ->
+  let open Fiber.O in
+  if all
+  then
+    let* dunes = registered_dunes () in
+    let+ statuses = Fiber.parallel_map ~f:get_status dunes in
+    print_statuses statuses
+  else (
+    let where = Rpc_common.active_server_exn () in
+    Console.print
+      [ Pp.textf "Server is listening on %s" (Dune_rpc.Where.to_string where)
+      ; Pp.text "Connected clients (including this one):"
+      ];
+    server_response_map ~where ~f:(fun clients ->
+      List.iter clients ~f:(fun (client, menu) ->
+        let id =
+          let sexp = Dune_rpc.Conv.to_sexp Dune_rpc.Id.sexp client in
+          Sexp.to_string sexp
+        in
+        let message =
+          match (menu : Dune_rpc_impl.Decl.Status.Menu.t) with
+          | Uninitialized -> [ Pp.textf "Client [%s], conducting version negotiation" id ]
+          | Menu menu ->
+            [ Pp.textf "Client [%s] with the following RPC versions:" id
+            ; Pp.enumerate menu ~f:(fun (method_, version) ->
+                Pp.textf "%s: %d" method_ version)
+            ]
+        in
+        Console.print message))
+    >>| function
+    | Ok () -> ()
+    | Error e -> Printf.printf "Error: %s\n" e)
+;;
+
+let info =
+  let doc = "show active connections" in
+  Cmd.info "status" ~doc
+;;
+
+let cmd = Cmd.v info term

unikernel/duniverse/dune_/bin/rpc/rpc_status.mli

@@ -0,0 +1,2 @@
+(** dune rpc status command *)
+val cmd : unit Cmdliner.Cmd.t