From 4e48a42fcc30f90b8db171d96348dd8ff04d4824 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicol=C3=A1s=20Ojeda=20B=C3=A4r?= Date: Thu, 1 Aug 2019 09:57:21 +0200 Subject: [PATCH] Add (with-stdin-from ...) (#2487) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Nicolás Ojeda Bär --- CHANGES.md | 5 +- doc/dune-files.rst | 1 + src/action.ml | 8 +- src/action.mli | 1 + src/action_ast.ml | 29 ++- src/action_exec.ml | 69 +++--- src/action_intf.ml | 9 +- src/action_mapper.ml | 6 +- src/action_to_sh.ml | 68 +++--- src/action_unexpanded.ml | 15 +- src/build.ml | 2 +- src/command.ml | 2 +- src/main.ml | 2 +- src/process.ml | 206 +++++++++++------- src/process.mli | 52 +++-- src/test_rules.ml | 2 +- test/blackbox-tests/dune.inc | 10 + .../test-cases/with-stdin-from/dune | 5 + .../test-cases/with-stdin-from/dune-project | 1 + .../test-cases/with-stdin-from/run.t | 3 + test/expect-tests/vcs_tests.ml | 2 +- 21 files changed, 330 insertions(+), 168 deletions(-) create mode 100644 test/blackbox-tests/test-cases/with-stdin-from/dune create mode 100644 test/blackbox-tests/test-cases/with-stdin-from/dune-project create mode 100644 test/blackbox-tests/test-cases/with-stdin-from/run.t diff --git a/CHANGES.md b/CHANGES.md index bc9a72a779d..cf2c8efd678 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -59,12 +59,15 @@ - Add a new config option `sandboxing_preference`, the cli argument `--sandbox`, and the dep spec `sandbox` in dune language. These let the user control the level of sandboxing done by dune per rule and globally. The rule specification takes precedence. - The global configuration merely specifies the default. + The global configuration merely specifies the default. (#2213, @aalekseyev, @jdimino) - Remove support for old style subsystems. Dune will now emit a warning to reinstall the library with the old style subsystem. (#2480, @rgrinberg) +- Add action (with-stdin-from ) to redirect input from + when performing . (#2487, @nojb) + 1.11.0 (23/07/2019) ------------------- diff --git a/doc/dune-files.rst b/doc/dune-files.rst index d89d6a3b9f4..7b3f2450522 100644 --- a/doc/dune-files.rst +++ b/doc/dune-files.rst @@ -1574,6 +1574,7 @@ The following constructions are available: ``stdout`` and ``stderr``) - ``(ignore- `` is one of: ``stdout``, ``stderr`` or ``outputs`` +- ``(with-stdin-from )`` to redirect the input from a file - ``(progn ...)`` to execute several commands in sequence - ``(echo )`` to output a string on stdout - ``(write-file )`` writes ```` to ```` diff --git a/src/action.ml b/src/action.ml index cf43232a7b9..7eaa795c4c1 100644 --- a/src/action.ml +++ b/src/action.ml @@ -2,6 +2,7 @@ open! Stdune open Import module Outputs = Action_ast.Outputs +module Inputs = Action_ast.Inputs module Prog = struct module Not_found = struct @@ -141,7 +142,8 @@ let fold_one_step t ~init:acc ~f = match t with | Chdir (_, t) | Setenv (_, _, t) - | Redirect (_, _, t) + | Redirect_out (_, _, t) + | Redirect_in (_, _, t) | Ignore (_, t) -> f acc t | Progn l -> List.fold_left l ~init:acc ~f | Run _ @@ -233,7 +235,9 @@ let is_useful_to_sandbox = loop t | Setenv (_, _, t) -> loop t - | Redirect (_, _, t) -> + | Redirect_out (_, _, t) -> + loop t + | Redirect_in (_, _, t) -> loop t | Ignore (_, t) -> loop t diff --git a/src/action.mli b/src/action.mli index 4b0bb5c4993..eff99ef8d8e 100644 --- a/src/action.mli +++ b/src/action.mli @@ -2,6 +2,7 @@ open! Stdune open! Import module Outputs : module type of struct include Action_intf.Outputs end +module Inputs : module type of struct include Action_intf.Inputs end (** result of the lookup of a program, the path to it or information about the failure and possibly a hint how to fix it *) diff --git a/src/action_ast.ml b/src/action_ast.ml index 2e2e3afc34b..7a109ceab66 100644 --- a/src/action_ast.ml +++ b/src/action_ast.ml @@ -13,6 +13,13 @@ module Outputs = struct | Outputs -> "outputs" end +module Inputs = struct + include Action_intf.Inputs + + let to_string = function + | Stdin -> "stdin" +end + module type Target_intf = sig include Dune_lang.Conv @@ -36,7 +43,7 @@ struct if Target.is_dev_null fn then Ignore (output, action) else - Redirect (output, fn, action) + Redirect_out (output, fn, action) let decode = let path = Path.decode in @@ -75,6 +82,12 @@ struct and+ t = t in translate_to_ignore fn Outputs t) + ; "with-stdin-from", + (Syntax.since Stanza.syntax (2, 0) >>> + let+ fn = path + and+ t = t + in + Redirect_in (Stdin, fn, t)) ; "ignore-stdout", (t >>| fun t -> Ignore (Stdout, t)) ; "ignore-stderr", @@ -136,11 +149,16 @@ struct List (atom "run" :: program a :: List.map xs ~f:string) | Chdir (a, r) -> List [atom "chdir" ; path a ; encode r] | Setenv (k, v, r) -> List [atom "setenv" ; string k ; string v ; encode r] - | Redirect (outputs, fn, r) -> + | Redirect_out (outputs, fn, r) -> List [ atom (sprintf "with-%s-to" (Outputs.to_string outputs)) ; target fn ; encode r ] + | Redirect_in (inputs, fn, r) -> + List [ atom (sprintf "with-%s-from" (Inputs.to_string inputs)) + ; path fn + ; encode r + ] | Ignore (outputs, r) -> List [ atom (sprintf "ignore-%s" (Outputs.to_string outputs)) ; encode r @@ -181,9 +199,10 @@ struct let run prog args = Run (prog, args) let chdir path t = Chdir (path, t) let setenv var value t = Setenv (var, value, t) - let with_stdout_to path t = Redirect (Stdout, path, t) - let with_stderr_to path t = Redirect (Stderr, path, t) - let with_outputs_to path t = Redirect (Outputs, path, t) + let with_stdout_to path t = Redirect_out (Stdout, path, t) + let with_stderr_to path t = Redirect_out (Stderr, path, t) + let with_outputs_to path t = Redirect_out (Outputs, path, t) + let with_stdin_from path t = Redirect_in (Stdin, path, t) let ignore_stdout t = Ignore (Stdout, t) let ignore_stderr t = Ignore (Stderr, t) let ignore_outputs t = Ignore (Outputs, t) diff --git a/src/action_exec.ml b/src/action_exec.ml index 150375c2058..9cbc769c037 100644 --- a/src/action_exec.ml +++ b/src/action_exec.ml @@ -7,7 +7,7 @@ type exec_context = ; purpose : Process.purpose } -let exec_run ~ectx ~dir ~env ~stdout_to ~stderr_to prog args = +let exec_run ~ectx ~dir ~env ~stdout_to ~stderr_to ~stdin_from prog args = begin match ectx.context with | None | Some { Context.for_host = None; _ } -> () @@ -29,38 +29,41 @@ let exec_run ~ectx ~dir ~env ~stdout_to ~stderr_to prog args = invalid_prefix (Path.relative Path.build_dir ("install/" ^ target.name)); end; Process.run Strict ~dir ~env - ~stdout_to ~stderr_to + ~stdout_to ~stderr_to ~stdin_from ~purpose:ectx.purpose prog args let exec_echo stdout_to str = - Fiber.return (output_string (Process.Output.channel stdout_to) str) + Fiber.return (output_string (Process.Io.out_channel stdout_to) str) -let rec exec t ~ectx ~dir ~env ~stdout_to ~stderr_to = +let rec exec t ~ectx ~dir ~env ~stdout_to ~stderr_to ~stdin_from = match (t : Action.t) with | Run (Error e, _) -> Action.Prog.Not_found.raise e | Run (Ok prog, args) -> - exec_run ~ectx ~dir ~env ~stdout_to ~stderr_to prog args + exec_run ~ectx ~dir ~env ~stdout_to ~stderr_to ~stdin_from prog args | Chdir (dir, t) -> - exec t ~ectx ~dir ~env ~stdout_to ~stderr_to + exec t ~ectx ~dir ~env ~stdout_to ~stderr_to ~stdin_from | Setenv (var, value, t) -> - exec t ~ectx ~dir ~stdout_to ~stderr_to + exec t ~ectx ~dir ~stdout_to ~stderr_to ~stdin_from ~env:(Env.add env ~var ~value) - | Redirect (Stdout, fn, Echo s) -> + | Redirect_out (Stdout, fn, Echo s) -> Io.write_file (Path.build fn) (String.concat s ~sep:" "); Fiber.return () - | Redirect (outputs, fn, t) -> + | Redirect_out (outputs, fn, t) -> let fn = Path.build fn in - redirect ~ectx ~dir outputs fn t ~env ~stdout_to ~stderr_to + redirect_out ~ectx ~dir outputs fn t ~env ~stdout_to ~stderr_to ~stdin_from + | Redirect_in (inputs, fn, t) -> + redirect_in ~ectx ~dir inputs fn t ~env ~stdout_to ~stderr_to ~stdin_from | Ignore (outputs, t) -> - redirect ~ectx ~dir outputs Config.dev_null t ~env ~stdout_to ~stderr_to + redirect_out ~ectx ~dir outputs Config.dev_null t ~env ~stdout_to ~stderr_to + ~stdin_from | Progn l -> - exec_list l ~ectx ~dir ~env ~stdout_to ~stderr_to + exec_list l ~ectx ~dir ~env ~stdout_to ~stderr_to ~stdin_from | Echo strs -> exec_echo stdout_to (String.concat strs ~sep:" ") | Cat fn -> Io.with_file_in fn ~f:(fun ic -> - Io.copy_channels ic (Process.Output.channel stdout_to)); + Io.copy_channels ic (Process.Io.out_channel stdout_to)); Fiber.return () | Copy (src, dst) -> let dst = Path.build dst in @@ -105,9 +108,9 @@ let rec exec t ~ectx ~dir ~env ~stdout_to ~stderr_to = let path, arg = Utils.system_shell_exn ~needed_to:"interpret (system ...) actions" in - exec_run ~ectx ~dir ~env ~stdout_to ~stderr_to path [arg; cmd] + exec_run ~ectx ~dir ~env ~stdout_to ~stderr_to ~stdin_from path [arg; cmd] | Bash cmd -> - exec_run ~ectx ~dir ~env ~stdout_to ~stderr_to + exec_run ~ectx ~dir ~env ~stdout_to ~stderr_to ~stdin_from (Utils.bash_exn ~needed_to:"interpret (bash ...) actions") ["-e"; "-u"; "-o"; "pipefail"; "-c"; cmd] | Write_file (fn, s) -> @@ -180,30 +183,41 @@ let rec exec t ~ectx ~dir ~env ~stdout_to ~stderr_to = Io.write_lines target (String.Set.to_list lines); Fiber.return () -and redirect outputs fn t ~ectx ~dir ~env ~stdout_to ~stderr_to = - let out = Process.Output.file fn in +and redirect_out outputs fn t ~ectx ~dir ~env ~stdout_to ~stderr_to ~stdin_from = + let out = Process.Io.file fn Process.Io.Out in let stdout_to, stderr_to = match outputs with | Stdout -> (out, stderr_to) | Stderr -> (stdout_to, out) | Outputs -> (out, out) in - exec t ~ectx ~dir ~env ~stdout_to ~stderr_to >>| fun () -> - Process.Output.release out + exec t ~ectx ~dir ~env ~stdout_to ~stderr_to ~stdin_from >>| fun () -> + Process.Io.release out -and exec_list l ~ectx ~dir ~env ~stdout_to ~stderr_to = +and redirect_in inputs fn t ~ectx ~dir ~env + ~stdout_to ~stderr_to ~stdin_from:_ = + let in_ = Process.Io.file fn Process.Io.In in + let stdin_from = + match inputs with + | Stdin -> in_ + in + exec t ~ectx ~dir ~env ~stdout_to ~stderr_to ~stdin_from >>| fun () -> + Process.Io.release in_ + +and exec_list l ~ectx ~dir ~env ~stdout_to ~stderr_to ~stdin_from = match l with | [] -> Fiber.return () | [t] -> - exec t ~ectx ~dir ~env ~stdout_to ~stderr_to + exec t ~ectx ~dir ~env ~stdout_to ~stderr_to ~stdin_from | t :: rest -> let* () = - let stdout_to = Process.Output.multi_use stdout_to in - let stderr_to = Process.Output.multi_use stderr_to in - exec t ~ectx ~dir ~env ~stdout_to ~stderr_to + let stdout_to = Process.Io.multi_use stdout_to in + let stderr_to = Process.Io.multi_use stderr_to in + let stdin_from = Process.Io.multi_use stdin_from in + exec t ~ectx ~dir ~env ~stdout_to ~stderr_to ~stdin_from in - exec_list rest ~ectx ~dir ~env ~stdout_to ~stderr_to + exec_list rest ~ectx ~dir ~env ~stdout_to ~stderr_to ~stdin_from let exec ~targets ~context ~env t = let env = @@ -215,5 +229,6 @@ let exec ~targets ~context ~env t = let purpose = Process.Build_job targets in let ectx = { purpose; context } in exec t ~ectx ~dir:Path.root ~env - ~stdout_to:Process.Output.stdout - ~stderr_to:Process.Output.stderr + ~stdout_to:Process.Io.stdout + ~stderr_to:Process.Io.stderr + ~stdin_from:Process.Io.stdin diff --git a/src/action_intf.ml b/src/action_intf.ml index fafbadb4443..8d647007c79 100644 --- a/src/action_intf.ml +++ b/src/action_intf.ml @@ -7,6 +7,11 @@ module Outputs = struct | Outputs (** Both Stdout and Stderr *) end +module Inputs = struct + type t = + | Stdin +end + module type Ast = sig type program type path @@ -19,7 +24,8 @@ module type Ast = sig | Setenv of string * string * t (* It's not possible to use a build path here since jbuild supports redirecting to /dev/null. In dune files this is replaced with %{null} *) - | Redirect of Outputs.t * target * t + | Redirect_out of Outputs.t * target * t + | Redirect_in of Inputs.t * path * t | Ignore of Outputs.t * t | Progn of t list | Echo of string list @@ -51,6 +57,7 @@ module type Helpers = sig val with_stdout_to : target -> t -> t val with_stderr_to : target -> t -> t val with_outputs_to : target -> t -> t + val with_stdin_from : path -> t -> t val ignore_stdout : t -> t val ignore_stderr : t -> t val ignore_outputs : t -> t diff --git a/src/action_mapper.ml b/src/action_mapper.ml index 2cd887254b6..52ec660ba8b 100755 --- a/src/action_mapper.ml +++ b/src/action_mapper.ml @@ -22,8 +22,10 @@ module Make Chdir (f_path ~dir fn, f t ~dir:fn) | Setenv (var, value, t) -> Setenv (f_string ~dir var, f_string ~dir value, f t ~dir) - | Redirect (outputs, fn, t) -> - Redirect (outputs, f_target ~dir fn, f t ~dir) + | Redirect_out (outputs, fn, t) -> + Redirect_out (outputs, f_target ~dir fn, f t ~dir) + | Redirect_in (inputs, fn, t) -> + Redirect_in (inputs, f_path ~dir fn, f t ~dir) | Ignore (outputs, t) -> Ignore (outputs, f t ~dir) | Progn l -> Progn (List.map l ~f:(fun t -> f t ~dir)) diff --git a/src/action_to_sh.ml b/src/action_to_sh.ml index e4b3cbd0a48..900ae02b3fe 100644 --- a/src/action_to_sh.ml +++ b/src/action_to_sh.ml @@ -2,12 +2,14 @@ open Import module Simplified = struct type destination = Dev_null | File of string + type source = string type t = | Run of string * string list | Chdir of string | Setenv of string * string - | Redirect of t list * Action.Outputs.t * destination + | Redirect_out of t list * Action.Outputs.t * destination + | Redirect_in of t list * Action.Inputs.t * source | Sh of string end open Simplified @@ -35,10 +37,12 @@ let simplify act = loop act (Chdir p :: mkdir p :: acc) | Setenv (k, v, act) -> loop act (Setenv (k, v) :: acc) - | Redirect (outputs, fn, act) -> - Redirect (block act, outputs, File fn) :: acc + | Redirect_out (outputs, fn, act) -> + Redirect_out (block act, outputs, File fn) :: acc + | Redirect_in (inputs, fn, act) -> + Redirect_in (block act, inputs, fn) :: acc | Ignore (outputs, act) -> - Redirect (block act, outputs, Dev_null) :: acc + Redirect_out (block act, outputs, Dev_null) :: acc | Progn l -> List.fold_left l ~init:acc ~f:(fun acc act -> loop act acc) | Echo xs -> echo (String.concat xs ~sep:"") @@ -49,15 +53,15 @@ let simplify act = | Symlink (x, y) -> Run ("ln", ["-s"; x; y]) :: Run ("rm", ["-f"; y]) :: acc | Copy_and_add_line_directive (x, y) -> - Redirect (echo (Utils.line_directive ~filename:x ~line_number:1) @ - [cat x], Stdout, File y) + Redirect_out (echo (Utils.line_directive ~filename:x ~line_number:1) @ + [cat x], Stdout, File y) :: acc | System x -> Sh x :: acc | Bash x -> Run ("bash", ["-e"; "-u"; "-o"; "pipefail"; "-c"; x]) :: acc | Write_file (x, y) -> - Redirect (echo y, Stdout, File x) :: acc + Redirect_out (echo y, Stdout, File x) :: acc | Rename (x, y) -> Run ("mv", [x; y]) :: acc | Remove_tree x -> @@ -93,7 +97,24 @@ let simplify act = let quote s = Pp.verbatim (String.quote_for_shell s) -let rec pp = function +let rec block l = + match l with + | [x] -> pp x + | l -> + Pp.box + (Pp.concat + [ Pp.hvbox ~indent:2 + (Pp.concat + [ Pp.char '{' + ; Pp.space + ; Pp.hvbox (Pp.concat_map l ~sep:Pp.space + ~f:(fun x -> Pp.seq (pp x) (Pp.char ';'))) + ]) + ; Pp.space + ; Pp.char '}' + ]) + +and pp = function | Run (prog, args) -> Pp.hovbox ~indent:2 (Pp.concat @@ -111,24 +132,19 @@ let rec pp = function Pp.concat [Pp.verbatim k; Pp.verbatim "="; quote v] | Sh s -> Pp.verbatim s - | Redirect (l, outputs, dest) -> - let body = - match l with - | [x] -> pp x - | l -> - Pp.box - (Pp.concat - [ Pp.hvbox ~indent:2 - (Pp.concat - [ Pp.char '{' - ; Pp.space - ; Pp.hvbox (Pp.concat_map l ~sep:Pp.space - ~f:(fun x -> Pp.seq (pp x) (Pp.char ';'))) - ]) - ; Pp.space - ; Pp.char '}' - ]) - in + | Redirect_in (l, inputs, src) -> + let body = block l in + Pp.hovbox ~indent:2 + (Pp.concat + [ body + ; Pp.space + ; Pp.verbatim (match inputs with + | Stdin -> "<") + ; Pp.space + ; quote src + ]) + | Redirect_out (l, outputs, dest) -> + let body = block l in Pp.hovbox ~indent:2 (Pp.concat [ body diff --git a/src/action_unexpanded.ml b/src/action_unexpanded.ml index f6e72f49976..0d4d71cc314 100644 --- a/src/action_unexpanded.ml +++ b/src/action_unexpanded.ml @@ -126,8 +126,10 @@ module Partial = struct let value = E.string ~expander value in let expander = Expander.set_env expander ~var ~value in Setenv (var, value, expand t ~expander ~map_exe) - | Redirect (outputs, fn, t) -> - Redirect (outputs, E.target ~expander fn, expand t ~map_exe ~expander) + | Redirect_out (outputs, fn, t) -> + Redirect_out (outputs, E.target ~expander fn, expand t ~map_exe ~expander) + | Redirect_in (inputs, fn, t) -> + Redirect_in (inputs, E.path ~expander fn, expand t ~map_exe ~expander) | Ignore (outputs, t) -> Ignore (outputs, expand t ~expander ~map_exe) | Progn l -> Progn (List.map l ~f:(expand ~expander ~map_exe)) @@ -245,8 +247,10 @@ let rec partial_expand t ~map_exe ~expander : Partial.t = | Right _ -> Expander.hide_env expander ~var in Setenv (Left var, value, partial_expand t ~expander ~map_exe) - | Redirect (outputs, fn, t) -> - Redirect (outputs, E.target ~expander fn, partial_expand t ~expander ~map_exe) + | Redirect_out (outputs, fn, t) -> + Redirect_out (outputs, E.target ~expander fn, partial_expand t ~expander ~map_exe) + | Redirect_in (inputs, fn, t) -> + Redirect_in (inputs, E.path ~expander fn, partial_expand t ~expander ~map_exe) | Ignore (outputs, t) -> Ignore (outputs, partial_expand t ~expander ~map_exe) | Progn l -> Progn (List.map l ~f:(partial_expand ~map_exe ~expander)) @@ -343,7 +347,8 @@ module Infer = struct let rec infer acc t = match t with | Run (prog, _) -> acc + infer (acc +@+ fn) t + | Redirect_out (_, fn, t) -> infer (acc +@+ fn) t + | Redirect_in (_, fn, t) -> infer (acc +< fn) t | Cat fn -> acc +< fn | Write_file (fn, _) -> acc +@+ fn | Rename (src, dst) -> acc +<+ src +@+ dst diff --git a/src/build.ml b/src/build.ml index 7f1d356e09c..1cfff0e80bf 100644 --- a/src/build.ml +++ b/src/build.ml @@ -204,7 +204,7 @@ let symlink ~src ~dst = action ~targets:[dst] (Symlink (src, dst)) let create_file fn = - action ~targets:[fn] (Redirect (Stdout, fn, Progn [])) + action ~targets:[fn] (Redirect_out (Stdout, fn, Progn [])) let remove_tree dir = arr (fun _ -> Action.Remove_tree dir) diff --git a/src/command.ml b/src/command.ml index 12e474ad50e..0e68c18d1e6 100644 --- a/src/command.ml +++ b/src/command.ml @@ -100,7 +100,7 @@ let run ~dir ?stdout_to prog args = let action = match stdout_to with | None -> action - | Some path -> Redirect (Stdout, path, action) + | Some path -> Redirect_out (Stdout, path, action) in Action.Chdir (dir, action) ) diff --git a/src/main.ml b/src/main.ml index ceae557a560..a2856c13697 100644 --- a/src/main.ml +++ b/src/main.ml @@ -141,7 +141,7 @@ let auto_concurrency = | Some prog -> let* result = Process.run_capture (Accept All) prog args ~env:Env.initial - ~stderr_to:(Process.Output.file Config.dev_null) + ~stderr_to:(Process.Io.file Config.dev_null Process.Io.Out) in match result with | Error _ -> loop rest diff --git a/src/process.ml b/src/process.ml index cfad10c5770..cba81708fa1 100644 --- a/src/process.ml +++ b/src/process.ml @@ -30,52 +30,93 @@ let map_result | 0 -> Ok (f ()) | n -> Error n -module Output = struct - type t = - { kind : kind - ; fd : Unix.file_descr Lazy.t - ; channel : out_channel Lazy.t - ; mutable status : status - } +module Io = struct + type input = Input + type output = Output + + type 'a mode = + | In : input mode + | Out : output mode - and kind = + type kind = | File of Path.t | Terminal - and status = + type status = | Keep_open | Close_after_exec | Closed - let terminal oc = - let fd = Unix.descr_of_out_channel oc in + type 'a channel = + | In_chan : in_channel -> input channel + | Out_chan : out_channel -> output channel + + let descr_of_channel : type a. a channel -> _ = function + | In_chan ic -> Unix.descr_of_in_channel ic + | Out_chan oc -> Unix.descr_of_out_channel oc + + let mode_of_channel : type a. a channel -> a mode = function + | In_chan _ -> In + | Out_chan _ -> Out + + let channel_of_descr : type a. _ -> a mode -> a channel = fun fd mode -> + match mode with + | In -> In_chan (Unix.in_channel_of_descr fd) + | Out -> Out_chan (Unix.out_channel_of_descr fd) + + let close_channel : type a. a channel -> unit = function + | Out_chan ch -> close_out ch + | In_chan ch -> close_in ch + + type 'a t = + { kind : kind + ; mode : 'a mode + ; fd : Unix.file_descr Lazy.t + ; channel : 'a channel Lazy.t + ; mutable status : status + } + + let terminal ch = + let fd = descr_of_channel ch in { kind = Terminal + ; mode = mode_of_channel ch ; fd = lazy fd - ; channel = lazy stdout + ; channel = lazy ch ; status = Keep_open } - let stdout = terminal stdout - let stderr = terminal stderr - - let file fn = - let fd = - lazy (Unix.openfile (Path.to_string fn) - [O_WRONLY; O_CREAT; O_TRUNC; O_SHARE_DELETE] 0o666) + let stdout = terminal (Out_chan stdout) + let stderr = terminal (Out_chan stderr) + let stdin = terminal (In_chan stdin) + + let file : type a. _ -> a mode -> a t = fun fn mode -> + let flags = + match mode with + | Out -> [Unix.O_WRONLY; O_CREAT; O_TRUNC; O_SHARE_DELETE] + | In -> [O_RDONLY; O_SHARE_DELETE] in + let fd = lazy (Unix.openfile (Path.to_string fn) flags 0o666) in + let channel = lazy (channel_of_descr (Lazy.force fd) mode) in { kind = File fn + ; mode ; fd - ; channel = lazy (Unix.out_channel_of_descr (Lazy.force fd)) + ; channel ; status = Close_after_exec } - let flush t = - if Lazy.is_val t.channel then flush (Lazy.force t.channel) + let flush : type a. a t -> unit = fun t -> + if Lazy.is_val t.channel then + match Lazy.force t.channel with + | Out_chan oc -> + flush oc + | In_chan _ -> + () let fd t = flush t; Lazy.force t.fd - let channel t = Lazy.force t.channel + let out_channel = function + | {channel = lazy (Out_chan oc); _} -> oc let release t = match t.status with @@ -84,7 +125,7 @@ module Output = struct | Close_after_exec -> t.status <- Closed; if Lazy.is_val t.channel then - close_out (Lazy.force t.channel) + close_channel (Lazy.force t.channel) else Unix.close (Lazy.force t.fd) @@ -114,13 +155,21 @@ module Temp = struct tmp_files := Path.Set.remove !tmp_files fn end -let command_line_enclosers ~dir ~(stdout_to:Output.t) ~(stderr_to:Output.t) = +let command_line_enclosers ~dir + ~(stdout_to:Io.output Io.t) + ~(stderr_to:Io.output Io.t) + ~(stdin_from:Io.input Io.t) = let quote fn = String.quote_for_shell (Path.to_string fn) in let prefix, suffix = match dir with | None -> "", "" | Some dir -> sprintf "(cd %s && " (quote dir), ")" in + let suffix = + match stdin_from.kind with + | Terminal -> suffix + | File fn -> suffix ^ " < " ^ quote fn + in let suffix = match stdout_to.kind, stderr_to.kind with | File fn1, File fn2 when Path.equal fn1 fn2 -> @@ -137,12 +186,13 @@ let command_line_enclosers ~dir ~(stdout_to:Output.t) ~(stderr_to:Output.t) = in (prefix, suffix) -let command_line ~prog ~args ~dir ~stdout_to ~stderr_to = +let command_line ~prog ~args ~dir ~stdout_to ~stderr_to ~stdin_from = let s = List.map (prog :: args) ~f:String.quote_for_shell |> String.concat ~sep:" " in - let prefix, suffix = command_line_enclosers ~dir ~stdout_to ~stderr_to in + let prefix, suffix = + command_line_enclosers ~dir ~stdout_to ~stderr_to ~stdin_from in prefix ^ s ^ suffix module Fancy = struct @@ -215,13 +265,14 @@ module Fancy = struct :: colorize_args rest | x :: rest -> Pp.verbatim (String.quote_for_shell x) :: colorize_args rest - let command_line ~prog ~args ~dir ~stdout_to ~stderr_to = + let command_line ~prog ~args ~dir ~stdout_to ~stderr_to ~stdin_from = let open Pp.O in let prog = colorize_prog (String.quote_for_shell prog) in let pp = Pp.concat ~sep:(Pp.char ' ') (prog :: colorize_args args) in - let prefix, suffix = command_line_enclosers ~dir ~stdout_to ~stderr_to in + let prefix, suffix = + command_line_enclosers ~dir ~stdout_to ~stderr_to ~stdin_from in Pp.verbatim prefix ++ pp ++ Pp.verbatim suffix let pp_purpose = function @@ -408,8 +459,8 @@ module Exit_status = struct :: Option.to_list output) end -let run_internal ?dir ?(stdout_to=Output.stdout) ?(stderr_to=Output.stderr) - ~env ~purpose fail_mode prog args = +let run_internal ?dir ?(stdout_to=Io.stdout) ?(stderr_to=Io.stderr) + ?(stdin_from=Io.stdin) ~env ~purpose fail_mode prog args = let* scheduler = Scheduler.wait_for_available_job () in let display = Console.display () in let dir = @@ -425,14 +476,15 @@ let run_internal ?dir ?(stdout_to=Output.stdout) ?(stderr_to=Output.stderr) let ok_codes = accepted_codes fail_mode in let prog_str = Path.reach_for_running ?from:dir prog in let command_line = - command_line ~prog:prog_str ~args ~dir ~stdout_to ~stderr_to + command_line ~prog:prog_str ~args ~dir ~stdout_to ~stderr_to ~stdin_from in let fancy_command_line = match display with | Verbose -> let open Pp.O in let cmdline = - Fancy.command_line ~prog:prog_str ~args ~dir ~stdout_to ~stderr_to + Fancy.command_line ~prog:prog_str ~args ~dir + ~stdout_to ~stderr_to ~stdin_from in Console.print_user_message (User_message.make @@ -449,7 +501,7 @@ let run_internal ?dir ?(stdout_to=Output.stdout) ?(stderr_to=Output.stderr) | Not_supported -> (args, None) | Zero_terminated_strings arg -> let fn = Temp.create "responsefile" ".data" in - Io.with_file_out fn ~f:(fun oc -> + Stdune.Io.with_file_out fn ~f:(fun oc -> List.iter args ~f:(fun arg -> output_string oc arg; output_char oc '\000')); @@ -462,10 +514,10 @@ let run_internal ?dir ?(stdout_to=Output.stdout) ?(stderr_to=Output.stderr) match stdout_to.kind, stderr_to.kind with | (Terminal, _ | _, Terminal) when !Clflags.capture_outputs -> let fn = Temp.create "dune" ".output" in - let terminal = Output.file fn in - let get (out : Output.t) = + let terminal = Io.file fn Io.Out in + let get (out : Io.output Io.t) = if out.kind = Terminal then begin - Output.flush out; + Io.flush out; terminal end else out @@ -478,8 +530,9 @@ let run_internal ?dir ?(stdout_to=Output.stdout) ?(stderr_to=Output.stderr) (* Output.fd might create the file with Unix.openfile. We need to make sure to call it before doing the chdir as the path might be relative. *) - let stdout = Output.fd stdout_to in - let stderr = Output.fd stderr_to in + let stdout = Io.fd stdout_to in + let stderr = Io.fd stderr_to in + let stdin = Io.fd stdin_from in fun () -> Spawn.spawn () ~prog:prog_str @@ -487,14 +540,15 @@ let run_internal ?dir ?(stdout_to=Output.stdout) ?(stderr_to=Output.stderr) ~env:(Spawn.Env.of_array (Env.to_unix env)) ~stdout ~stderr + ~stdin in let pid = match dir with | None -> run () | Some dir -> Scheduler.with_chdir scheduler ~dir ~f:run in - Output.release stdout_to; - Output.release stderr_to; + Io.release stdout_to; + Io.release stderr_to; let+ exit_status = Stats.with_process ~program:prog_str ~args (Scheduler.wait_for_process pid) in @@ -503,7 +557,7 @@ let run_internal ?dir ?(stdout_to=Output.stdout) ?(stderr_to=Output.stderr) match output_filename with | None -> "" | Some fn -> - let s = Io.read_file fn in + let s = Stdune.Io.read_file fn in Temp.destroy fn; s in @@ -524,48 +578,50 @@ let run_internal ?dir ?(stdout_to=Output.stdout) ?(stderr_to=Output.stderr) Exit_status.handle_non_verbose exit_status ~prog:prog_str ~command_line ~output ~purpose ~display -let run ?dir ?stdout_to ?stderr_to ~env ?(purpose=Internal_job) fail_mode - prog args = +let run ?dir ?stdout_to ?stderr_to ?stdin_from ~env + ?(purpose=Internal_job) fail_mode prog args = map_result fail_mode - (run_internal ?dir ?stdout_to ?stderr_to ~env ~purpose fail_mode prog args) + (run_internal ?dir ?stdout_to ?stderr_to ?stdin_from + ~env ~purpose fail_mode prog args) ~f:ignore -let run_capture_gen ?dir ?stderr_to ~env ?(purpose=Internal_job) fail_mode - prog args ~f = +let run_capture_gen ?dir ?stderr_to ?stdin_from ~env ?(purpose=Internal_job) + fail_mode prog args ~f = let fn = Temp.create "dune" ".output" in map_result fail_mode - (run_internal ?dir ~stdout_to:(Output.file fn) ?stderr_to + (run_internal ?dir ~stdout_to:(Io.file fn Io.Out) ?stderr_to ?stdin_from ~env ~purpose fail_mode prog args) ~f:(fun () -> let x = f fn in Temp.destroy fn; x) -let run_capture = run_capture_gen ~f:Io.read_file -let run_capture_lines = run_capture_gen ~f:Io.lines_of_file +let run_capture = run_capture_gen ~f:Stdune.Io.read_file +let run_capture_lines = run_capture_gen ~f:Stdune.Io.lines_of_file -let run_capture_line ?dir ?stderr_to ~env ?(purpose=Internal_job) fail_mode - prog args = - run_capture_gen ?dir ?stderr_to ~env ~purpose fail_mode prog args ~f:(fun fn -> - match Io.lines_of_file fn with - | [x] -> x - | l -> - let cmdline = - let prog = Path.reach_for_running ?from:dir prog in - let prog_display = String.concat (prog :: args) ~sep:" " in - match dir with - | None -> prog_display - | Some dir -> sprintf "cd %s && %s" (Path.to_string dir) prog_display - in - match l with - | [] -> - User_error.raise - [ Pp.textf "Command returned nothing: %s" cmdline ] - | _ -> - User_error.raise - [ Pp.textf "command returned too many lines: %s" cmdline - ; Pp.vbox - (Pp.concat_map l ~sep:Pp.cut - ~f:(fun line -> - Pp.seq (Pp.verbatim "> ") (Pp.verbatim line))) - ]) +let run_capture_line ?dir ?stderr_to ?stdin_from ~env ?(purpose=Internal_job) + fail_mode prog args = + run_capture_gen ?dir ?stderr_to ?stdin_from ~env ~purpose fail_mode prog args + ~f:(fun fn -> + match Stdune.Io.lines_of_file fn with + | [x] -> x + | l -> + let cmdline = + let prog = Path.reach_for_running ?from:dir prog in + let prog_display = String.concat (prog :: args) ~sep:" " in + match dir with + | None -> prog_display + | Some dir -> sprintf "cd %s && %s" (Path.to_string dir) prog_display + in + match l with + | [] -> + User_error.raise + [ Pp.textf "Command returned nothing: %s" cmdline ] + | _ -> + User_error.raise + [ Pp.textf "command returned too many lines: %s" cmdline + ; Pp.vbox + (Pp.concat_map l ~sep:Pp.cut + ~f:(fun line -> + Pp.seq (Pp.verbatim "> ") (Pp.verbatim line))) + ]) diff --git a/src/process.mli b/src/process.mli index ae9760522ab..845812aa013 100644 --- a/src/process.mli +++ b/src/process.mli @@ -14,27 +14,36 @@ type ('a, 'b) failure_mode = (** Accept the following non-zero exit codes, and return [Error code] if the process exists with one of these codes. *) -module Output : sig - (** Where to redirect stdout/stderr *) - type t +module Io : sig + (** Where to redirect stdout/stderr/stdin *) + type input = Input + type output = Output - val stdout : t - val stderr : t + type 'a mode = + | In : input mode + | Out : output mode - (** Create a [t] representing redirecting the output to a file. The - returned output can only be used by a single call to {!run}. If - you want to use it multiple times, you need to use [clone]. *) - val file : Path.t -> t + type 'a t - (** Call this when you no longer need this output *) - val release : t -> unit + val stdout : output t + val stderr : output t + val stdin : input t (** Return a buffered channel for this output. The channel is created lazily. *) - val channel : t -> out_channel + val out_channel : output t -> out_channel + + (** Create a [t] representing redirecting the input or to a file or reading + input from the file. The returned channel can only be used by a single + call to {!run}. If you want to use it multiple times, you need to use + [clone]. *) + val file : Path.t -> 'a mode -> 'a t + + (** Call this when you no longer need this redirection *) + val release : 'a t -> unit (** [multi_use t] returns a copy for which [release] does nothing *) - val multi_use : t -> t + val multi_use : 'a t -> 'a t end (** Why a Fiber.t was run *) @@ -42,11 +51,13 @@ type purpose = | Internal_job | Build_job of Path.Build.Set.t -(** [run ?dir ?stdout_to prog args] spawns a sub-process and wait for its termination *) +(** [run ?dir ?stdout_to prog args] spawns a sub-process and wait for its + termination *) val run : ?dir:Path.t - -> ?stdout_to:Output.t - -> ?stderr_to:Output.t + -> ?stdout_to:Io.output Io.t + -> ?stderr_to:Io.output Io.t + -> ?stdin_from:Io.input Io.t -> env:Env.t -> ?purpose:purpose -> (unit, 'a) failure_mode @@ -57,7 +68,8 @@ val run (** Run a command and capture its output *) val run_capture : ?dir:Path.t - -> ?stderr_to:Output.t + -> ?stderr_to:Io.output Io.t + -> ?stdin_from:Io.input Io.t -> env:Env.t -> ?purpose:purpose -> (string, 'a) failure_mode @@ -66,7 +78,8 @@ val run_capture -> 'a Fiber.t val run_capture_line : ?dir:Path.t - -> ?stderr_to:Output.t + -> ?stderr_to:Io.output Io.t + -> ?stdin_from:Io.input Io.t -> env:Env.t -> ?purpose:purpose -> (string, 'a) failure_mode @@ -75,7 +88,8 @@ val run_capture_line -> 'a Fiber.t val run_capture_lines : ?dir:Path.t - -> ?stderr_to:Output.t + -> ?stderr_to:Io.output Io.t + -> ?stdin_from:Io.input Io.t -> env:Env.t -> ?purpose:purpose -> (string list, 'a) failure_mode diff --git a/src/test_rules.ml b/src/test_rules.ml index 1abbdd484fe..bbec09b7c7c 100644 --- a/src/test_rules.ml +++ b/src/test_rules.ml @@ -53,7 +53,7 @@ let rules (t : Dune_file.Tests.t) ~sctx ~dir ~scope ~expander ~dir_contents = targets = Infer ; deps = Bindings.empty ; action = - (loc, Action_unexpanded.Redirect (Stdout, diff.file2, run_action)) + (loc, Action_unexpanded.Redirect_out (Stdout, diff.file2, run_action)) ; mode = Standard ; locks = t.locks ; loc diff --git a/test/blackbox-tests/dune.inc b/test/blackbox-tests/dune.inc index 4f519d4f39b..b9fcca22a42 100644 --- a/test/blackbox-tests/dune.inc +++ b/test/blackbox-tests/dune.inc @@ -1622,6 +1622,14 @@ test-cases/windows-diff (progn (run %{exe:cram.exe} -test run.t) (diff? run.t run.t.corrected))))) +(alias + (name with-stdin-from) + (deps (package dune) (source_tree test-cases/with-stdin-from)) + (action + (chdir + test-cases/with-stdin-from + (progn (run %{exe:cram.exe} -test run.t) (diff? run.t run.t.corrected))))) + (alias (name workspace-paths) (deps (package dune) (source_tree test-cases/workspace-paths)) @@ -1852,6 +1860,7 @@ (alias vlib-default-impl) (alias vlib-wrong-default-impl) (alias windows-diff) + (alias with-stdin-from) (alias workspace-paths) (alias workspaces) (alias wrapped-false-main-module-name) @@ -2028,6 +2037,7 @@ (alias vlib-default-impl) (alias vlib-wrong-default-impl) (alias windows-diff) + (alias with-stdin-from) (alias workspace-paths) (alias workspaces) (alias wrapped-false-main-module-name) diff --git a/test/blackbox-tests/test-cases/with-stdin-from/dune b/test/blackbox-tests/test-cases/with-stdin-from/dune new file mode 100644 index 00000000000..3737927643f --- /dev/null +++ b/test/blackbox-tests/test-cases/with-stdin-from/dune @@ -0,0 +1,5 @@ +(rule (with-stdout-to input.txt (echo "Hello!\n"))) + +(alias + (name runtest) + (action (with-stdin-from input.txt (run cat)))) diff --git a/test/blackbox-tests/test-cases/with-stdin-from/dune-project b/test/blackbox-tests/test-cases/with-stdin-from/dune-project new file mode 100644 index 00000000000..929c696e561 --- /dev/null +++ b/test/blackbox-tests/test-cases/with-stdin-from/dune-project @@ -0,0 +1 @@ +(lang dune 2.0) diff --git a/test/blackbox-tests/test-cases/with-stdin-from/run.t b/test/blackbox-tests/test-cases/with-stdin-from/run.t new file mode 100644 index 00000000000..4a1dbb8ce0c --- /dev/null +++ b/test/blackbox-tests/test-cases/with-stdin-from/run.t @@ -0,0 +1,3 @@ + $ dune runtest --display short + cat alias runtest + Hello! diff --git a/test/expect-tests/vcs_tests.ml b/test/expect-tests/vcs_tests.ml index 4b4ed528929..44ce78cd6f5 100644 --- a/test/expect-tests/vcs_tests.ml +++ b/test/expect-tests/vcs_tests.ml @@ -41,7 +41,7 @@ let run (vcs : Vcs.t) args = ~var:"GIT_DIR" ~value:(Filename.concat (Path.to_absolute_filename vcs.root) ".git")) ~dir:vcs.root - ~stdout_to:(Process.Output.file Config.dev_null) + ~stdout_to:(Process.Io.file Config.dev_null Process.Io.Out) type action = | Init