A unix socket path too long for sun_path is bound and reached through its directory, so flan dev runs under any TMPDIR and -s path

lib/dev.ml

@@ -213,7 +213,7 @@ let over_socket t line =
   Fun.protect
     ~finally:(fun () -> try Unix.close s with Unix.Unix_error _ -> ())
     (fun () ->
-       Unix.connect s (Unix.ADDR_UNIX t.agent);
+       Wire.connect_socket s t.agent;
        let msg = line ^ "\n" in
        ignore (Unix.write_substring s msg 0 (String.length msg));
        let b = Bytes.create 4096 in
@@ -940,8 +940,7 @@ let refusal ~parked reply =
    frame boundary is the next one it reaches. That includes a running program
    whose agent socket is not bound. The agent package binds it in a
    constructor before [main], so the one way to be running and unbound with
-   the agent linked is a bind that failed — a socket path longer than
+   the agent linked is a bind that failed, and there
-   [max_socket_path], which [session_dir] refuses before building — and there
    the module is still queued through the in-process call. A note saying the
    program "has not called (agent/start ...)" named a cause that was not the
    cause, so there is none. *)
@@ -5357,20 +5356,15 @@ let remove_session_dirs t =
   remove t.dir;
   remove (Build.workdir ())
 
-(* The longest path a unix socket can be bound at: [sun_path] is 108 bytes on
+(* A socket path longer than [Wire.max_socket_path] is bound through its
-   Linux and the path is written into it with its terminating NUL. A longer one
+   directory, so only a file name too long for that is refused. *)
-   fails at the bind, where the reason reaches nobody — the agent's constructor
-   drops it, and [connect] later answers "File name too long" with no path. *)
-let max_socket_path = 107
-
 let socket_fits ~what ~fix path =
-  let n = String.length path in
+  if not (Wire.socket_fits path) then
-  if n > max_socket_path then
     failwith
       (Printf.sprintf
-         "%s would be at %s, which is %d bytes long, and a unix socket path \
+         "%s would be at %s, and its file name, %s, is too long for a unix \
-          can be at most %d bytes. %s"
+          socket. %s"
-         what path n max_socket_path fix)
+         what path (Filename.basename path) fix)
 
 (* The directory a session keeps its program, its modules and the agent's
    socket in, checked before anything is built so that a TMPDIR that cannot
@@ -5378,11 +5372,6 @@ let socket_fits ~what ~fix path =
 let session_dir ~file ~sock =
   let tmp = Filename.get_temp_dir_name () in
   let dir = Filename.concat tmp (Printf.sprintf "flan-dev-%d" (Unix.getpid ())) in
-  let shorter =
-    Printf.sprintf
-      "Set TMPDIR to a shorter directory, for example: TMPDIR=/tmp flan dev %s"
-      (Filename.quote file)
-  in
   if not (Sys.file_exists tmp && Sys.is_directory tmp) then
     failwith
       (Printf.sprintf
@@ -5390,10 +5379,8 @@ let session_dir ~file ~sock =
           program there. Create it, or set TMPDIR to a directory that exists, \
           for example: TMPDIR=/tmp flan dev %s"
          tmp (Filename.quote file));
-  socket_fits ~what:"the program's agent socket" ~fix:shorter
-    (Filename.concat dir "agent.sock");
   socket_fits ~what:"the editor's socket"
-    ~fix:"Give flan dev -s a shorter path." sock;
+    ~fix:"Give flan dev -s a shorter file name." sock;
   dir
 
 (* Made only once the program has been found to have something to run, so a
@@ -5586,7 +5573,7 @@ let two_process ?(debug = false) ?(sanitize = false) ?(x86 = true) ~file ~sock (
   ignore_sigpipe ();
   (try Unix.unlink sock with Unix.Unix_error _ -> ());
   let ls = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in
-  Unix.bind ls (Unix.ADDR_UNIX sock);
+  Wire.bind_socket ls sock;
   Unix.listen ls 4;
   Printf.eprintf "flan dev: %s ready on %s (%.0fms)\n%!" file sock
     ((Unix.gettimeofday () -. t0) *. 1000.);
@@ -6448,7 +6435,7 @@ let merged_setup () =
     ignore_sigpipe ();
     (try Unix.unlink sock with Unix.Unix_error _ -> ());
     let ls = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in
-    Unix.bind ls (Unix.ADDR_UNIX sock);
+    Wire.bind_socket ls sock;
     Unix.listen ls 4;
     merged_state := Some (t, ls, sock);
     Printf.eprintf "flan dev: %s ready on %s (%.0fms, one process)\n%!" file

lib/wire.ml

@@ -29,6 +29,38 @@ let quote s =
 let list items = "(" ^ String.concat " " items ^ ")"
 let strings ss = list (List.map quote ss)
 
+(* A unix socket path is at most 107 bytes: [sun_path] is 108 and holds the
+   terminating NUL. A longer one is reached through its directory instead,
+   opened and named as [/proc/self/fd/N/], which Linux resolves like the path
+   itself, so only the file's own name has to fit. The descriptor is closed as
+   soon as the bind or connect returns; the socket file stays where it was
+   made. *)
+let max_socket_path = 107
+
+let proc_prefix = String.length "/proc/self/fd/2147483647/"
+
+let socket_fits path =
+  String.length path <= max_socket_path
+  || String.length (Filename.basename path) + proc_prefix <= max_socket_path
+
+let with_socket_addr path k =
+  if String.length path <= max_socket_path then k (Unix.ADDR_UNIX path)
+  else begin
+    let d =
+      Unix.openfile (Filename.dirname path) [ Unix.O_RDONLY; Unix.O_CLOEXEC ] 0
+    in
+    Fun.protect
+      ~finally:(fun () -> try Unix.close d with Unix.Unix_error _ -> ())
+      (fun () ->
+         (* A [file_descr] is the fd number on Unix. *)
+         k (Unix.ADDR_UNIX
+              (Printf.sprintf "/proc/self/fd/%d/%s" (Obj.magic d : int)
+                 (Filename.basename path))))
+  end
+
+let bind_socket s path = with_socket_addr path (Unix.bind s)
+let connect_socket s path = with_socket_addr path (Unix.connect s)
+
 let send fd payload =
   let framed = Printf.sprintf "%d\n%s" (String.length payload) payload in
   let n = String.length framed in

test/test_dev.ml

@@ -5832,14 +5832,11 @@ let () =
 
     (* ── What stops a session from starting, said at the start ─────────
 
-       Three things a session cannot start without, each refused before
+       Two things a session cannot start without, each refused before
-       anything is built, in both shapes, with the fix named: a TMPDIR that
+       anything is built, with the fix named: a TMPDIR that does not exist (it
-       does not exist (it was an uncaught ENOENT out of mkdir), one so deep
+       was an uncaught ENOENT out of mkdir), and a program with no main (a
-       that the agent's socket path does not fit in a unix socket address
+       link error, or a sentence about the merged build's internals). A TMPDIR
-       (the bind failed where nobody heard it, and every reply after that
+       too deep for a socket path is not one of them; see the session below. *)
-       said "File name too long" or asked about (agent/start ...)), and a
-       program with no main (a link error, or a sentence about the merged
-       build's internals). *)
     let refused_at_start what ~tmpdir ~prog ~mode want =
       let out = tmp "start-refusal.out" in
       let fd = Unix.openfile out [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in
@@ -5870,17 +5867,10 @@ let () =
         want
     in
     let here = Filename.get_temp_dir_name () in
-    let deep =
-      Filename.concat here (String.make (max 1 (110 - String.length here)) 'd')
-    in
-    Unix.mkdir deep 0o700;
     let missing = Filename.concat here "no-such-directory" in
     let nomain = "programs/dev-nomain.flan" in
     List.iter
       (fun mode ->
-         refused_at_start "a TMPDIR too deep for a socket path" ~tmpdir:deep
-           ~prog:"programs/dev-lateagent.flan" ~mode
-           [ "at most 107 bytes"; "TMPDIR=/tmp flan dev" ];
          refused_at_start "a TMPDIR that does not exist" ~tmpdir:missing
            ~prog:"programs/dev-lateagent.flan" ~mode
            [ missing ^ " does not exist"; "TMPDIR=/tmp flan dev" ];
@@ -5890,7 +5880,80 @@ let () =
            refused_at_start "a program with no main" ~tmpdir:here ~prog:nomain
              ~mode [ "has no main"; "(defn main [] i32"; "without --two-process" ])
       [ [||]; [| "--two-process" |] ];
-    (try Unix.rmdir deep with Unix.Unix_error _ -> ());
+
+    (* ── A session under a TMPDIR too deep for a socket path ────────────
+
+       Both sockets are past the 107 bytes a unix socket address holds: the
+       editor's, named with -s, and the agent's, which the daemon puts under
+       TMPDIR. Both are bound and reached through their directory, so the
+       session starts and an evaluation reaches the program, in both shapes.
+       It used to be refused, and before that it failed at the bind. *)
+    let deep =
+      Filename.concat here (String.make (max 1 (110 - String.length here)) 'd')
+    in
+    Unix.mkdir deep 0o700;
+    List.iter
+      (fun mode ->
+         let shape = if mode = [||] then "one process" else "--two-process" in
+         let dsock = Filename.concat deep "editor-socket-for-a-deep-tmpdir.sock"
+         and dout = tmp "deep.out" in
+         let fd =
+           Unix.openfile dout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600
+         in
+         let env =
+           Array.append [| "TMPDIR=" ^ deep |]
+             (Array.of_list
+                (List.filter
+                   (fun v -> not (String.starts_with ~prefix:"TMPDIR=" v))
+                   (Array.to_list (Unix.environment ()))))
+         in
+         let pid =
+           Unix.create_process_env flan
+             (Array.append
+                [| flan; "dev"; "programs/dev-pause.flan"; "-s"; dsock |] mode)
+             env Unix.stdin fd fd
+         in
+         Unix.close fd;
+         if not (listening ~pid dsock) then begin
+           fail "a deep TMPDIR (%s): the daemon %s (%S)" shape !listen_why
+             (In_channel.with_open_bin dout In_channel.input_all);
+           (try Unix.kill pid Sys.sigkill with Unix.Unix_error _ -> ())
+         end
+         else begin
+           let c = connect dsock in
+           let said r =
+             Option.value ~default:(status r) (Wire.string_field r "message")
+           in
+           let r =
+             request c
+               "(:op \"eval\" :code \"(defn boom [] i64 7)\" :file \
+                \"programs/dev-pause.flan\")"
+           in
+           if status r <> "ok" then
+             fail "a deep TMPDIR (%s): eval: %s" shape (said r);
+           let answered = ref "" in
+           let seven () =
+             let r =
+               request c
+                 "(:op \"eval-expr\" :code \"(boom)\" :file \
+                  \"programs/dev-pause.flan\")"
+             in
+             answered := Option.value ~default:(said r) (Wire.string_field r "value");
+             !answered = "7"
+           in
+           if not (await ~ms:20000 seven) then
+             fail "a deep TMPDIR (%s): (boom) answered %S" shape !answered;
+           (try
+              ignore (Wire.send c "(:op \"close\")");
+              ignore (Wire.recv c)
+            with _ -> ());
+           (try Unix.close c with Unix.Unix_error _ -> ());
+           (try Unix.kill pid Sys.sigkill with Unix.Unix_error _ -> ());
+           (try ignore (Unix.waitpid [] pid) with Unix.Unix_error _ -> ())
+         end;
+         (try Sys.remove dout with Sys_error _ -> ()))
+      [ [||]; [| "--two-process" |] ];
+    Own_tmp.remove deep;
 
     (* ── A build that fails is a refusal, not the end of the session ── *)
 
@@ -6241,7 +6304,7 @@ let () =
       let hit_and_run () =
         let s = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in
         (try
-           Unix.connect s (Unix.ADDR_UNIX rsock);
+           Wire.connect_socket s rsock;
            Wire.send s "(:op \"describe\")"
          with Unix.Unix_error _ -> ());
         (try Unix.close s with Unix.Unix_error _ -> ())

test/test_support.ml

@@ -89,7 +89,12 @@ let scratch = Own_tmp.dir
    same time under dune, so "flan-agent-dev.sock" and "flan-repl-dev.sock"
    being different files is what keeps two suites from unlinking each other's
    sockets. *)
-let tmp prefix name = Filename.concat scratch (prefix ^ name)
+let tmp prefix name =
+  (* A socket goes without the prefix: [scratch] is this binary's alone, and a
+     unix socket path is short (see [Wire.max_socket_path]), which an emacs
+     client connecting by the plain path cannot get around. *)
+  if Filename.check_suffix name ".sock" then Filename.concat scratch name
+  else Filename.concat scratch (prefix ^ name)
 
 (* ── Toolchain probes ─────────────────────────────────────────────── *)
 
@@ -126,7 +131,7 @@ let rec await ?(ms = 5000) f =
    disk, so the race this does catch is the only one left. *)
 let rec connect ?(ms = 5000) path =
   let s = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in
-  match Unix.connect s (Unix.ADDR_UNIX path) with
+  match Wire.connect_socket s path with
   | () -> s
   | exception Unix.Unix_error (Unix.ECONNREFUSED, _, _) when ms > 0 ->
     Unix.close s;

vendor/agent/flan_agent.c

@@ -43,6 +43,7 @@
 #endif
 #include <dlfcn.h>
 #include <errno.h>
+#include <fcntl.h>
 #include <stdlib.h>
 #include <pthread.h>
 #include <setjmp.h>
@@ -1015,6 +1016,10 @@ int32_t flan_agent_poll(void);
  * came from. */
 static char bound_sock[sizeof(((struct sockaddr_un *)0)->sun_path)];
 
+/* The directory a socket path too long for sun_path was bound through, or -1;
+ * see [start_on]. */
+static int sock_dir_fd = -1;
+
 /* A socket file outlives the process that bound it, and a stale one answers
  * the next client with ECONNREFUSED — which reads like a program that is there
  * and refusing rather than one that has gone. So the bind registers its own
@@ -2732,10 +2737,32 @@ static int32_t start_on(const char *path) {
   int made = 0;
   if (atomic_exchange(&started, 1)) return 1;
   len = strlen(path);
-  if (len == 0 || len >= sizeof addr.sun_path) goto failed;
+  if (len == 0) goto failed;
   memset(&addr, 0, sizeof addr);
   addr.sun_family = AF_UNIX;
-  memcpy(addr.sun_path, path, len);
+  if (len < sizeof addr.sun_path) {
+    memcpy(addr.sun_path, path, len);
+  } else {
+    /* Too long for sun_path: bound through its directory, opened and named
+     * as /proc/self/fd/N/, which Linux resolves like the path itself. The
+     * descriptor stays open for the life of the process, because the unlinks
+     * at exit go through the same name. */
+    const char *slash = strrchr(path, '/');
+    char dir[4096];
+    int n;
+    size_t dlen = slash == NULL ? 0 : (size_t)(slash - path);
+    if (slash == NULL || dlen >= sizeof dir) goto failed;
+    memcpy(dir, path, dlen);
+    dir[dlen] = '\0';
+    if (sock_dir_fd < 0)
+      sock_dir_fd = open(dlen == 0 ? "/" : dir,
+                         O_RDONLY | O_DIRECTORY | O_CLOEXEC);
+    if (sock_dir_fd < 0) goto failed;
+    n = snprintf(addr.sun_path, sizeof addr.sun_path, "/proc/self/fd/%d/%s",
+                 sock_dir_fd, slash + 1);
+    if (n < 0 || (size_t)n >= sizeof addr.sun_path) goto failed;
+    len = (size_t)n;
+  }
   unlink(addr.sun_path);
   fd = socket(AF_UNIX, SOCK_STREAM, 0);
   if (fd < 0) goto failed;
@@ -2814,7 +2841,7 @@ static const char *daemon_socket(void) {
  * and guessing wrong fails silently: everything compiles, the module is built,
  * and nothing ever receives it. */
 int32_t flan_agent_start(const uint8_t *path, int64_t len) {
-  char buf[sizeof(((struct sockaddr_un *)0)->sun_path)];
+  char buf[4096];
   const char *env = daemon_socket();
   if (env != NULL) return start_on(env) < 0 ? -1 : 0;
   if (len <= 0 || (size_t)len >= sizeof buf) return -1;