fix: create fake socket rpc file on windows (#6329)

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

Author: rgrinberg

Diff for: 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)
 ------------------
 

Diff for: 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

Diff for: 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

Diff for: 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 }
 

Diff for: 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

Diff for: 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

Diff for: 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