From 69ac194ba714df5e1fe4fae1da3d547835f41ad4 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 22:54:44 +0700 Subject: [PATCH] An editor socket path too long to connect to is linked at a short path the Emacs client computes the same way --- emacs/flan.el | 22 +++++++++++++++- lib/dev.ml | 33 ++++++++++++++++++++++- lib/wire.ml | 18 +++++++++++++ test/test_emacs.ml | 66 ++++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 137 insertions(+), 2 deletions(-) diff --git a/emacs/flan.el b/emacs/flan.el index 6f5f576e..1f8ca0db 100644 --- a/emacs/flan.el +++ b/emacs/flan.el @@ -673,6 +673,26 @@ Set to nil to leave the program's state to whatever replies happen to say." flan-socket-name))) (and dir (expand-file-name flan-socket-name dir)))) +(defun flan--short-socket (socket) + "The path to connect to SOCKET by. +A unix socket path holds at most 107 bytes, and a longer one cannot be +connected to by name. For such a SOCKET the daemon makes a symlink at a +short path computed from it, and this computes the same one: see +`Wire.short_socket_path' in lib/wire.ml." + (let ((abs (expand-file-name socket))) + (if (<= (string-bytes abs) 107) + socket + (let* ((env (getenv "XDG_RUNTIME_DIR")) + (dir (if (and env (not (string= env "")) (file-directory-p env)) + env + "/tmp"))) + (expand-file-name + (concat "flan-" + (substring (secure-hash 'md5 (encode-coding-string abs 'utf-8)) + 0 16) + ".sock") + dir))))) + (defun flan--open (socket) "Open a connection to SOCKET and make it the current one." (when (process-live-p flan--connection) @@ -683,7 +703,7 @@ Set to nil to leave the program's state to whatever replies happen to say." (with-current-buffer buf (erase-buffer) (set-buffer-multibyte nil)) (setq flan--connection (make-network-process - :name "flan" :buffer buf :family 'local :service socket + :name "flan" :buffer buf :family 'local :service (flan--short-socket socket) :coding 'binary :noquery t :filter #'flan--filter :sentinel #'flan--sentinel)) (setq flan--socket socket)) diff --git a/lib/dev.ml b/lib/dev.ml index 33e10e3a..028e350a 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -5366,6 +5366,33 @@ let socket_fits ~what ~fix path = socket. %s" what path (Filename.basename path) fix) +(* An editor socket too long to connect to by path gets a symlink at + [Wire.short_socket_path], made before the bind so it is there by the time + the socket is, and removed on a clean end only while it is still this + socket's. *) +let absolute p = + if Filename.is_relative p then Filename.concat (Sys.getcwd ()) p else p + +let link_short_socket sock = + if String.length sock > Wire.max_socket_path then begin + let s = Wire.short_socket_path sock in + (match (Unix.lstat s).Unix.st_kind with + | Unix.S_LNK -> (try Unix.unlink s with Unix.Unix_error _ -> ()) + | _ -> () + | exception Unix.Unix_error _ -> ()); + try Unix.symlink (absolute sock) s with Unix.Unix_error _ -> () + end + +let unlink_short_socket sock = + if String.length sock > Wire.max_socket_path then begin + let s = Wire.short_socket_path sock in + match Unix.readlink s with + | target when String.equal target (absolute sock) -> + (try Unix.unlink s with Unix.Unix_error _ -> ()) + | _ -> () + | exception Unix.Unix_error _ -> () + end + (* 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 hold one is said once, at the start, in words. *) @@ -5573,6 +5600,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 + link_short_socket sock; Wire.bind_socket ls sock; Unix.listen ls 4; Printf.eprintf "flan dev: %s ready on %s (%.0fms)\n%!" file sock @@ -5585,7 +5613,8 @@ let two_process ?(debug = false) ?(sanitize = false) ?(x86 = true) ~file ~sock ( | None -> ()); (try Unix.close ls with Unix.Unix_error _ -> ()); (try Unix.close t.stdout with Unix.Unix_error _ -> ()); - (try Unix.unlink sock with Unix.Unix_error _ -> ())) + (try Unix.unlink sock with Unix.Unix_error _ -> ()); + unlink_short_socket sock) (fun () -> accept_loop t ls); (* Here only when the loop returned: an exception out of it has already left through the [finally]. A child killed by a signal is the crash that @@ -6435,6 +6464,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 + link_short_socket sock; Wire.bind_socket ls sock; Unix.listen ls 4; merged_state := Some (t, ls, sock); @@ -6495,6 +6525,7 @@ let merged_serve () = in (try Unix.close ls with Unix.Unix_error _ -> ()); (try Unix.unlink sock with Unix.Unix_error _ -> ()); + unlink_short_socket sock; (* The program is this process, so a program that crashed never gets here; the one end that does and is not clean is the loop raising. *) if clean then remove_session_dirs t; diff --git a/lib/wire.ml b/lib/wire.ml index f1b2e581..a2d161b8 100644 --- a/lib/wire.ml +++ b/lib/wire.ml @@ -58,6 +58,24 @@ let with_socket_addr path k = (Filename.basename path)))) end +(* Where a client that cannot use the directory route above — Emacs, whose + [make-network-process] takes only a path — finds a socket whose own path is + too long: a symlink the daemon makes at a short path computed from the long + one, the same way on both sides. emacs/flan.el's [flan--short-socket] is + the other copy of this rule. *) +let short_socket_path path = + let abs = + if Filename.is_relative path then Filename.concat (Sys.getcwd ()) path + else path + in + let dir = + match Sys.getenv_opt "XDG_RUNTIME_DIR" with + | Some d when d <> "" && Sys.file_exists d && Sys.is_directory d -> d + | _ -> "/tmp" + in + Filename.concat dir + ("flan-" ^ String.sub (Digest.to_hex (Digest.string abs)) 0 16 ^ ".sock") + let bind_socket s path = with_socket_addr path (Unix.bind s) let connect_socket s path = with_socket_addr path (Unix.connect s) diff --git a/test/test_emacs.ml b/test/test_emacs.ml index c2b2ebe1..13364e97 100644 --- a/test/test_emacs.ml +++ b/test/test_emacs.ml @@ -148,3 +148,69 @@ let () = exit 1 end end + +(* A socket path longer than a unix socket address holds, which Emacs cannot + connect to by name: the daemon links it at a short path, the client + computes the same one, and the link goes when the session is closed. *) +let () = + let have = Test_support.have in + if have "emacs" && have "clang" && have "llc" then begin + let deep = + Filename.concat Test_support.scratch + (String.make (max 1 (110 - String.length Test_support.scratch)) 'd') + in + Unix.mkdir deep 0o700; + let sock = Filename.concat deep "an-editor-socket-past-the-limit.sock" + and err = tmp "long.err" in + let efd = Unix.openfile err [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in + let flan = "../bin/main.exe" in + let pid = + Unix.create_process flan + [| flan; "dev"; "programs/dev-pause.flan"; "-s"; sock |] + Unix.stdin efd efd + in + Unix.close efd; + let short = Flan.Wire.short_socket_path sock in + let failed = ref false in + let fail fmt = + Printf.ksprintf (fun s -> failed := true; print_endline ("FAIL " ^ s)) fmt + in + if not (listening ~pid sock) then fail "the long-socket daemon %s" !listen_why + else begin + let code = + Sys.command + (Printf.sprintf + "emacs -Q --batch -L ../../../emacs -l flan --eval %s 2>&1" + (Filename.quote + (Printf.sprintf + "(progn (flan--open %S) \ + (flan--send flan--connection '(:op \"describe\")) \ + (let ((r (flan--read-reply flan--connection))) \ + (flan--send flan--connection '(:op \"close\")) \ + (ignore-errors (flan--read-reply flan--connection)) \ + (delete-process flan--connection) \ + (kill-emacs (if (equal (plist-get r :status) \"ok\") 0 1))))" + sock))) + in + if code <> 0 then + fail "emacs could not talk to a daemon on a %d-byte socket path \ + (exit %d; daemon: %s)" (String.length sock) code + (In_channel.with_open_bin err In_channel.input_all) + end; + if not (await ~ms:5000 (fun () -> + match Unix.waitpid [ Unix.WNOHANG ] pid with + | 0, _ -> false + | _ -> true + | exception Unix.Unix_error _ -> true)) + then begin + (try Unix.kill pid Sys.sigkill with Unix.Unix_error _ -> ()); + (try ignore (Unix.waitpid [] pid) with Unix.Unix_error _ -> ()); + fail "the long-socket daemon did not end when the client left" + end + else if (try ignore (Unix.lstat short); true with Unix.Unix_error _ -> false) + then fail "the short link %s was left after a clean end" short; + (try Unix.unlink short with Unix.Unix_error _ -> ()); + (try Sys.remove err with Sys_error _ -> ()); + Own_tmp.remove deep; + if !failed then exit 1 else print_endline "emacs: a long socket path connects" + end