flan/lib/wire.ml

(** The editor protocol: one s-expression per message, length framed.

    Not bencode and not nREPL, and the reason is that both ends are ours. There
    is no CIDER to be compatible with, nREPL's [eval] is string-in/string-out
    with no slot for *which form, from which file*, and Emacs already has
    [read] and [prin1] — so a sexp protocol is no parsing code on that side and
    a few lines here, where the reader that parses it is the language's own.
    An nREPL server can be a second front end on the same [Session] later; it
    should not gate the editor.

    Framing is a decimal byte count, a newline, then that many bytes. A message
    carries Flan source, which contains newlines, so a line-oriented protocol
    would need an escape layer that this does not. *)

(* Elisp's [read] understands \\n and \\t but not OCaml's \\ddd, so this
   escapes the two characters that must be escaped and passes everything else
   through as itself. Both readers take a raw newline inside a string. *)
let quote s =
  let b = Buffer.create (String.length s + 8) in
  Buffer.add_char b '"';
  String.iter
    (fun c ->
       if c = '"' || c = '\\' then Buffer.add_char b '\\';
       Buffer.add_char b c)
    s;
  Buffer.add_char b '"';
  Buffer.contents b

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

(* 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)

let send fd payload =
  let framed = Printf.sprintf "%d\n%s" (String.length payload) payload in
  let n = String.length framed in
  let rec go i =
    if i < n then
      match Unix.write_substring fd framed i (n - i) with
      | 0 -> ()
      | k -> go (i + k)
  in
  go 0

exception Closed

let read_exactly fd n =
  let b = Bytes.create n in
  let rec go i =
    if i = n then Bytes.to_string b
    else
      match Unix.read fd b i (n - i) with
      | 0 -> raise Closed
      | k -> go (i + k)
  in
  go 0

(* The header is short and read a byte at a time, which keeps the payload
   boundary exact without a buffer that would have to be carried between
   calls. *)
let recv fd =
  let b = Bytes.create 1 in
  let buf = Buffer.create 16 in
  let rec header () =
    match Unix.read fd b 0 1 with
    | 0 -> raise Closed
    | _ ->
      if Bytes.get b 0 = '\n' then Buffer.contents buf
      else begin Buffer.add_char buf (Bytes.get b 0); header () end
  in
  let n =
    match int_of_string_opt (String.trim (header ())) with
    | Some n when n >= 0 -> n
    | _ -> raise Closed
  in
  read_exactly fd n

(* A request is read by the language's own reader, so [:op] is a keyword and a
   payload of Flan source is an ordinary string literal. *)
let field (form : Form.t) key =
  let rec go = function
    | { Form.v = Form.Kw k; _ } :: v :: rest ->
      if String.equal k key then Some v else go rest
    | _ :: rest -> go rest
    | [] -> None
  in
  match form.Form.v with Form.List l -> go l | _ -> None

let string_field form key =
  match field form key with
  | Some { Form.v = Form.Str s; _ } -> Some s
  | _ -> None

(* A restart is chosen by index, so the protocol has to carry one. Kept as
   narrow as [string_field]: a form that is not an integer is [None] and the
   op says what it wanted, rather than this guessing at a string. *)
let int_field form key =
  match field form key with
  | Some { Form.v = Form.Int i; _ } -> Some (Int64.to_int i)
  | _ -> None

let ints ns = list (List.map string_of_int ns)

let parse src =
  match Reader.read_all ~file:"<wire>" src with
  | [ f ] -> f
  | _ -> Loc.fail Loc.unknown "one form per message"

(* [:pause (LINE COL)] — where in the source just sent a [(pause)] goes. A
   position and not a span: the daemon matches it against the location the
   reader already attached to that form, so the editor says *which* form by
   saying where it starts. Anything that is not two integers is [None], and
   the op says what it wanted, exactly as [int_field] does. *)
let pos_field form key =
  match field form key with
  | Some { Form.v =
             Form.List [ { Form.v = Form.Int l; _ }; { Form.v = Form.Int c; _ } ];
           _ } ->
    Some (Int64.to_int l, Int64.to_int c)
  | _ -> None