From 5d09af9d377fcbbabeeb54a16c1ce020bf1cd24f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Thu, 27 Apr 2023 16:38:53 -0300 Subject: [PATCH] Move quoting inside the hook. Add detailed implementation constraints. --- src/ocaml/driver/pparse.ml | 52 ++++++++++++++++++++------------------ src/utils/lib_config.ml | 6 ++--- src/utils/lib_config.mli | 39 +++++++++++++++++++++++++--- src/utils/std.ml | 40 +++++++++++++++++++++++++---- 4 files changed, 101 insertions(+), 36 deletions(-) diff --git a/src/ocaml/driver/pparse.ml b/src/ocaml/driver/pparse.ml index a22c946a1a..077e93ff27 100644 --- a/src/ocaml/driver/pparse.ml +++ b/src/ocaml/driver/pparse.ml @@ -38,34 +38,29 @@ let report_error = function log ~title:"report_error" "External preprocessor does not produce a valid file. Command line: %s" cmd - -external windows_merlin_system_command : string -> cwd:string -> int = "ml_merlin_system_command" - let commandline prog args = - Printf.sprintf "%s %s" prog (String.concat ~sep:" " args) - -let merlin_system_command ~prog ~args ~cwd = - let cmd = commandline prog args in - if Sys.win32 then - windows_merlin_system_command cmd ~cwd - else - !Std.System_command.unix ~prog ~args ~cwd + Filename.quote_command prog args let apply_rewriter magic ppx (fn_in, failures) = let title = "apply_rewriter" in let fn_out = Filename.temp_file "camlppx" "" in - let args = - let redirect = - if Sys.win32 then [] else ["1>&2"] in - Filename.quote fn_in - :: Filename.quote fn_out - :: redirect - in + let args = [fn_in; fn_out] in let comm = commandline ppx.workval args in log ~title "running %s from directory %S" comm ppx.workdir; Logger.log_flush (); + let ok = + match + !System.run_in_directory + ~prog:ppx.workval + ~prog_is_quoted:true + ~args + ~cwd:ppx.workdir + () + with + | `Finished 0 -> true + | `Finished _ | `Cancelled -> false + in let failure = - let ok = merlin_system_command ~prog:ppx.workval ~args:args ~cwd:ppx.workdir = 0 in if not ok then Some (CannotRun comm) else if not (Sys.file_exists fn_out) then Some (WrongMagic comm) @@ -159,12 +154,21 @@ let apply_pp ~workdir ~filename ~source ~pp = close_out oc end; let fn_out = fn_in ^ ".out" in - let args = [ - Filename.quote fn_in; - Printf.sprintf "1>%s" (Filename.quote fn_out) - ] in + let args = [fn_in] in let comm = commandline pp args in - let ok = merlin_system_command ~prog:pp ~args:args ~cwd:workdir = 0 in + let ok = + match + !System.run_in_directory + ~prog:pp + ~prog_is_quoted:true + ~args + ~stdout:fn_out + ~cwd:workdir + () + with + | `Finished 0 -> true + | `Finished _ | `Cancelled -> false + in Misc.remove_file fn_in; if not ok then begin Misc.remove_file fn_out; diff --git a/src/utils/lib_config.ml b/src/utils/lib_config.ml index 6f1671ec6d..493124178f 100644 --- a/src/utils/lib_config.ml +++ b/src/utils/lib_config.ml @@ -9,7 +9,7 @@ module Json = struct Std.Json.pretty_to_string := f end -module System_command = struct - let set_unix f = - Std.System_command.unix := f +module System = struct + let set_run_in_directory f = + Std.System.run_in_directory := f end diff --git a/src/utils/lib_config.mli b/src/utils/lib_config.mli index fc2af4cfb2..7516d49be3 100644 --- a/src/utils/lib_config.mli +++ b/src/utils/lib_config.mli @@ -17,8 +17,39 @@ module Json : sig end (** Merlin spawns child processes for preprocessors (pp and ppx), which can be - customized via [System_command] *) -module System_command : sig - (** [set_unix] sets an implementation for Unix systems. *) - val set_unix : (prog:string -> args:string list -> cwd:string -> int) -> unit + customized via [System] *) +module System : sig + (** [set_run_in_directory] sets an implementation for spawning external + programs. This is used by Merlin to spawn preprocessors and ppxes. For + compatibility reasons, there are currently some limitations to how this + should be implemented: + + - Implementation should expect [prog] to be already quoted and contain + arguments. This is due to how ppx configuration is passed to Merlin. In + order to prepare a future transition to more sane argument passing, the + implementation can look at the [prog_is_quoted] argument to know if it + is actually safe to quote the command normally (using + [Filename.quote_command] for example). + + - [prog] might contain shell expansions, command substitutions etc. It + should therefore be ran under a shell for maximum compatibility. However + this should never happen when the configuration is generated by Dune. + + - Programs runned by this function should never output on stdout since it + is the channel used by Merlin to communicate with the editor. One way to + enforce that is to redirect stdout to stderr. + + - As of today Merlin handles the [`Cancelled] return case identically as + other error codes. *) + val set_run_in_directory + : (prog:string + -> prog_is_quoted:bool + -> args:string list + -> cwd:string + -> ?stdin:string + -> ?stdout:string + -> ?stderr:string + -> unit + -> [ `Finished of int | `Cancelled ]) + -> unit end diff --git a/src/utils/std.ml b/src/utils/std.ml index 69d9df4152..c8ce443ad7 100644 --- a/src/utils/std.ml +++ b/src/utils/std.ml @@ -751,11 +751,41 @@ module Shell = struct List.rev !comps end -module System_command = struct - let unix = ref @@ - fun ~prog ~args ~cwd -> - let cmd = Printf.sprintf "%s %s" prog (String.concat ~sep:" " args) in - Sys.command (Printf.sprintf "cd %s && %s" (Filename.quote cwd) cmd) +module System = struct + external windows_merlin_system_command : string -> cwd:string -> int = + "ml_merlin_system_command" + + let run_in_directory + : (prog:string + -> prog_is_quoted:bool + -> args:string list + -> cwd:string + -> ?stdin:string + -> ?stdout:string + -> ?stderr:string + -> unit + -> [ `Finished of int | `Cancelled ]) ref = ref @@ + fun ~prog ~prog_is_quoted:_ ~args ~cwd ?stdin:_ ?stdout ?stderr:_ () -> + (* Currently we assume that [prog] is always quoted and might contain + arguments such as [-as-ppx]. This is due to the way Merlin gets its + configuration. Thus we cannot rely on [Filename.quote_command]. *) + let args = String.concat ~sep:" " @@ List.map ~f:Filename.quote args in + let args = match stdout with + | Some file -> Format.sprintf "%s 1>%s" args (Filename.quote file) + | None -> + (* Runned program should never output on stdout since it is the + channel used by Merlin to communicate with the editor *) + if Sys.win32 then args else Format.sprintf "%s 1>&2" args + in + let cmd = Format.sprintf "%s %s" prog args in + let exit_code = + if Sys.win32 then + (* Note: the following function will never output to stdout *) + windows_merlin_system_command cmd ~cwd + else + Sys.command (Printf.sprintf "cd %s && %s" (Filename.quote cwd) cmd) + in + `Finished exit_code end (* [modules_in_path ~ext path] lists ocaml modules corresponding to