fix: create fake socket rpc file on windows

To allow connections to an rpc instance that isn't in the registry.
Previously, the socket file was only created on Unix. So windows users
couldn't point their clients at _build/.rpc/dune and connect.

Signed-off-by: Rudi Grinberg <[email protected]>

ps-id: c7483b66-9ba3-430e-b5c3-2c3e52a2b1ca

CHANGES.md

@@ -21,6 +21,9 @@ Unreleased
 - Allow absolute build directories to find public executables. For example,
   those specified with `(deps %{bin:...})` (#6326, @anmonteiro)
 
+- Create a fake socket file `_build/.rpc/dune` on windows to allow rpc clients
+  to connect using the build directory. (#6329, @rgrinberg)
+
 3.5.0 (2022-10-19)
 ------------------
 

otherlibs/dune-rpc/private/where.mli

@@ -5,6 +5,8 @@ type t =
   | `Ip of [ `Host of string ] * [ `Port of int ]
   ]
 
+val rpc_socket_relative_to_build_dir : string
+
 val to_string : t -> string
 
 val compare : t -> t -> Ordering.t

src/csexp_rpc/csexp_rpc.ml

@@ -226,21 +226,9 @@ module Server = struct
       ; buf : Bytes.t
       }
 
-    let create sockaddr ~backlog =
-      let fd =
-        Unix.socket ~cloexec:true
-          (Unix.domain_of_sockaddr sockaddr)
-          Unix.SOCK_STREAM 0
-      in
-      Unix.setsockopt fd Unix.SO_REUSEADDR true;
+    let create fd sockaddr ~backlog =
       Unix.set_nonblock fd;
-      (match sockaddr with
-      | ADDR_UNIX p ->
-        let p = Path.of_string p in
-        Path.unlink_no_err p;
-        Path.mkdir_p (Path.parent_exn p);
-        at_exit (fun () -> Path.unlink_no_err p)
-      | _ -> ());
+      Unix.setsockopt fd Unix.SO_REUSEADDR true;
       Socket.bind fd sockaddr;
       Unix.listen fd backlog;
       let r_interrupt_accept, w_interrupt_accept = Unix.pipe ~cloexec:true () in
@@ -276,61 +264,77 @@ module Server = struct
   end
 
   type t =
-    { mutable transport : Transport.t option
+    { mutable state :
+        [ `Init of Unix.file_descr | `Running of Transport.t | `Closed ]
     ; backlog : int
     ; sockaddr : Unix.sockaddr
     }
 
-  let create sockaddr ~backlog = { sockaddr; backlog; transport = None }
+  let create sockaddr ~backlog =
+    let fd =
+      Unix.socket ~cloexec:true
+        (Unix.domain_of_sockaddr sockaddr)
+        Unix.SOCK_STREAM 0
+    in
+    { sockaddr; backlog; state = `Init fd }
 
   let serve (t : t) =
     let* async = Worker.create () in
-    let+ transport =
-      Worker.task_exn async ~f:(fun () ->
-          Transport.create t.sockaddr ~backlog:t.backlog)
-    in
-    t.transport <- Some transport;
-    let accept () =
-      Worker.task async ~f:(fun () ->
-          Transport.accept transport
-          |> Option.map ~f:(fun client ->
-                 let in_ = Unix.in_channel_of_descr client in
-                 let out = Unix.out_channel_of_descr client in
-                 (in_, out)))
-    in
-    let loop () =
-      let* accept = accept () in
-      match accept with
-      | Error `Stopped ->
-        Log.info [ Pp.text "RPC stopped accepting." ];
-        Fiber.return None
-      | Error (`Exn exn) ->
-        Log.info
-          [ Pp.text "RPC accept failed. Server will not accept new clients"
-          ; Exn_with_backtrace.pp exn
-          ];
-        Fiber.return None
-      | Ok None ->
-        Log.info
-          [ Pp.text
-              "RPC accepted the last client. No more clients will be accepted."
-          ];
-        Fiber.return None
-      | Ok (Some (in_, out)) ->
-        let+ session = Session.create ~socket:true in_ out in
-        Some session
-    in
-    Fiber.Stream.In.create loop
+    match t.state with
+    | `Closed -> Code_error.raise "already closed" []
+    | `Running _ -> Code_error.raise "already running" []
+    | `Init fd ->
+      let+ transport =
+        Worker.task_exn async ~f:(fun () ->
+            Transport.create fd t.sockaddr ~backlog:t.backlog)
+      in
+      t.state <- `Running transport;
+      let accept () =
+        Worker.task async ~f:(fun () ->
+            Transport.accept transport
+            |> Option.map ~f:(fun client ->
+                   let in_ = Unix.in_channel_of_descr client in
+                   let out = Unix.out_channel_of_descr client in
+                   (in_, out)))
+      in
+      let loop () =
+        let* accept = accept () in
+        match accept with
+        | Error `Stopped ->
+          Log.info [ Pp.text "RPC stopped accepting." ];
+          Fiber.return None
+        | Error (`Exn exn) ->
+          Log.info
+            [ Pp.text "RPC accept failed. Server will not accept new clients"
+            ; Exn_with_backtrace.pp exn
+            ];
+          Fiber.return None
+        | Ok None ->
+          Log.info
+            [ Pp.text
+                "RPC accepted the last client. No more clients will be \
+                 accepted."
+            ];
+          Fiber.return None
+        | Ok (Some (in_, out)) ->
+          let+ session = Session.create ~socket:true in_ out in
+          Some session
+      in
+      Fiber.Stream.In.create loop
 
   let stop t =
-    match t.transport with
-    | None -> Code_error.raise "server not running" []
-    | Some t -> Transport.stop t
+    let () =
+      match t.state with
+      | `Closed -> ()
+      | `Running t -> Transport.stop t
+      | `Init fd -> Unix.close fd
+    in
+    t.state <- `Closed
 
   let listening_address t =
-    match t.transport with
-    | None -> Code_error.raise "server not running" []
-    | Some t -> Unix.getsockname t.fd
+    match t.state with
+    | `Init fd | `Running { Transport.fd; _ } -> Unix.getsockname fd
+    | `Closed -> Code_error.raise "server is already closed" []
 end
 
 module Client = struct

src/dune_rpc_impl/server.ml

@@ -57,6 +57,11 @@ module Run = struct
   let t_var : t Fiber.Var.t = Fiber.Var.create ()
 
   let of_config { Config.handler; backlog; pool; root; where } stats =
+    let () =
+      let socket_file = Where.rpc_socket_file () in
+      Path.mkdir_p (Path.build (Path.Build.parent_exn socket_file));
+      at_exit (fun () -> Path.Build.unlink_no_err socket_file)
+    in
     let server = Csexp_rpc.Server.create (Where.to_socket where) ~backlog in
     { server; handler; stats; pool; root; where }
 

src/dune_rpc_impl/where.ml

@@ -48,3 +48,11 @@ let to_socket = function
 let to_string = function
   | `Unix p -> sprintf "unix://%s" p
   | `Ip (`Host host, `Port port) -> sprintf "%s:%d" host port
+
+let rpc_socket_file =
+  let f =
+    lazy
+      (Path.Build.(relative root)
+         Dune_rpc_private.Where.rpc_socket_relative_to_build_dir)
+  in
+  fun () -> Lazy.force f

src/dune_rpc_impl/where.mli

@@ -8,4 +8,6 @@ val get : unit -> Dune_rpc.Where.t option
 
 val to_socket : Dune_rpc.Where.t -> Unix.sockaddr
 
+val rpc_socket_file : unit -> Path.Build.t
+
 val to_string : Dune_rpc.Where.t -> string

test/expect-tests/csexp_rpc/csexp_rpc_tests.ml

@@ -9,7 +9,14 @@ type event =
   | Fill of Fiber.fill
   | Abort
 
-let server where = Server.create where ~backlog:10
+let server (where : Unix.sockaddr) =
+  (match where with
+  | ADDR_UNIX p ->
+    let p = Path.of_string p in
+    Path.unlink_no_err p;
+    Path.mkdir_p (Path.parent_exn p)
+  | _ -> ());
+  Server.create where ~backlog:10
 
 let client where = Csexp_rpc.Client.create where