Add (with-stdin-from ...) (#2487)

Signed-off-by: Nicolás Ojeda Bär <n.oje.bar@gmail.com>

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 <file> <action>) to redirect input from <file>
+  when performing <action>. (#2487, @nojb)
+
 1.11.0 (23/07/2019)
 -------------------
 

doc/dune-files.rst

@@ -1574,6 +1574,7 @@ The following constructions are available:
   ``stdout`` and ``stderr``)
 - ``(ignore-<outputs> <DSL)`` to ignore the output, where
   ``<outputs>`` is one of: ``stdout``, ``stderr`` or ``outputs``
+- ``(with-stdin-from <file> <DSL>)`` to redirect the input from a file
 - ``(progn <DSL>...)`` to execute several commands in sequence
 - ``(echo <string>)`` to output a string on stdout
 - ``(write-file <file> <string>)`` writes ``<string>`` to ``<file>``

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

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

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)

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

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

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