diff --git a/lib/dev.ml b/lib/dev.ml index 0ee5f343..94983a82 100644 --- a/lib/dev.ml +++ b/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 - [max_socket_path], which [session_dir] refuses before building — and there + the agent linked is a bind that failed, 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 - Linux and the path is written into it with its terminating NUL. A longer one - 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 - +(* A socket path longer than [Wire.max_socket_path] is bound through its + directory, so only a file name too long for that is refused. *) let socket_fits ~what ~fix path = - let n = String.length path in - if n > max_socket_path then + if not (Wire.socket_fits path) then failwith (Printf.sprintf - "%s would be at %s, which is %d bytes long, and a unix socket path \ - can be at most %d bytes. %s" - what path n max_socket_path fix) + "%s would be at %s, and its file name, %s, is too long for a unix \ + socket. %s" + 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 diff --git a/lib/wire.ml b/lib/wire.ml index cabf274a..f1b2e581 100644 --- a/lib/wire.ml +++ b/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 diff --git a/test/test_dev.ml b/test/test_dev.ml index 72a203bb..836fdc09 100644 --- a/test/test_dev.ml +++ b/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 - anything is built, in both shapes, with the fix named: a TMPDIR that - does not exist (it was an uncaught ENOENT out of mkdir), one so deep - that the agent's socket path does not fit in a unix socket address - (the bind failed where nobody heard it, and every reply after that - 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). *) + Two things a session cannot start without, each refused before + anything is built, with the fix named: a TMPDIR that does not exist (it + was an uncaught ENOENT out of mkdir), and a program with no main (a + link error, or a sentence about the merged build's internals). A TMPDIR + too deep for a socket path is not one of them; see the session below. *) 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 _ -> ()) diff --git a/test/test_support.ml b/test/test_support.ml index 33622278..5e739ecc 100644 --- a/test/test_support.ml +++ b/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; diff --git a/vendor/agent/flan_agent.c b/vendor/agent/flan_agent.c index e0b4c4f2..e5c687f7 100644 --- a/vendor/agent/flan_agent.c +++ b/vendor/agent/flan_agent.c @@ -43,6 +43,7 @@ #endif #include #include +#include #include #include #include @@ -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;