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

@@ -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))

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;

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)
 

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