Improve redirections

src/lib/EDSL.mli

@@ -126,12 +126,53 @@ val make_switch :
   default:unit Language.t -> unit Language.t
 (**/**)
 
+(** {3 Redirections } *)
 
 type fd_redirection
+(** Abstract type of file-descriptor redirections. *)
+
 val to_fd: int t -> int t -> fd_redirection
+(** Create a file-descriptor to  file-descriptor redirection. *)
+
 val to_file: int t -> string t -> fd_redirection
+(** Create a file-descriptor to file redirection. *)
+
 val with_redirections:
   unit t -> fd_redirection list -> unit t
+(** 
+   Run a [unit t] expression after applying a list of file-descriptor
+   redirections.
+
+   The redirections are applied in the list's order.
+
+   Cf. the example:
+   {[
+       with_redirections (exec ["printf"; "%s"; "hello"]) [
+         to_file (int 3) (string "/path/to/one");
+         to_file (int 3) (string "/path/to/two");
+         to_fd (int 2) (int 3);
+         to_fd (int 1) (int 2);
+       ];
+   ]}
+
+   ["printf '%s' 'hello'"] will output to the file ["/path/to/two"],
+   because redirections are set in that order:
+
+   - file-descriptor [3] is set to output to ["/path/to/one"],
+   - file-descriptor [3] is set to output to ["/path/to/two"]
+     (overriding the previous redirection),
+   - file-descriptor [2] is redirected to file-descriptor [3],
+   - file-descriptor [1] is redirected to file-descriptor [2],
+   - then, ["printf"] outputs to [1].
+
+   Invalid cases, like redirecting to a file-descriptor has not been
+   opened, lead to undefined behavior; see
+   {{:https://github.com/hammerlab/genspio/issues/41}issue #41}.
+   If the shell is POSIX, the whole expression [with_redirections expr redirs]
+   exits and its return value is in [[1, 125]]; if the shell is
+   ["bash"] or ["zsh"], the failing redirection is just ignored and [expr] is
+   executed with the remaining redirections if any.
+*)
 
 val write_output :
   ?stdout:string t ->

src/lib/language.ml

@@ -292,25 +292,41 @@ let rec to_shell: type a. _ -> a t -> string =
     | Not t ->
       sprintf "! { %s ; }" (continue t)
     | Redirect_output (unit_t, redirections) ->
-      let variables = ref [] in
+      (* 
+         We're here compiling the redirections into `exec` statements which
+         set up global redirections; we limit their scope with `( .. )`.
+         E.g.
+         (  exec 3>/tmp/output-of-ls ; exec 2>&3 ; exec 1>&2 ; ls ; ) ; 
+      *)
       let make_redirection { take; redirect_to } =
         let takearg = to_argument "redirection_take" (`Int take) in
         let retoarg =
           to_argument "redirection_to"
             (match redirect_to with `Fd i -> `Int i | `Path p -> `String p) in
-        variables := takearg#export :: retoarg#export :: !variables;
-        sprintf "%s>%s%s"
-          takearg#argument
-          (match redirect_to with `Fd _ -> "&" | `Path _ -> " ")
-          retoarg#argument
+        let variables =
+          takearg#export :: retoarg#export :: [] |> List.filter_opt in
+        let exec =
+          sprintf "\"exec %%s>%s%%s\" %s %s"
+            (match redirect_to with `Fd _ -> "&" | `Path _ -> "")
+            takearg#argument
+            retoarg#argument
+        in
+        sprintf "%s eval \"$(printf %s)\" || { echo 'Exec %s failed' >&2 ; } "
+          (String.concat variables ~sep:"")
+          exec
+          exec
       in
-      let compiled_redirections =
-        List.rev_map redirections ~f:make_redirection in
-      let command = Construct.string (continue unit_t) in
-      sprintf "%s eval \"{ $(%s) ; } %s\" "
-        (String.concat (List.filter_opt !variables) ~sep:"")
-        (expand_octal (continue command))
-        (String.concat ~sep:" " compiled_redirections)
+      begin match redirections with
+      | [] -> continue unit_t
+      | one :: more ->
+        continue (Seq (
+            Raw_cmd (sprintf "( %s" (make_redirection one))
+            ::
+            List.map more ~f:(fun r -> Raw_cmd (make_redirection r))
+            @ [unit_t]
+            @ [ Raw_cmd ")" ]
+          ))
+      end
     | Write_output { expr; stdout; stderr; return_value } ->
       let ret_arg =
         Option.map return_value ~f:(fun v -> to_argument "retval" (`String v))

src/test/main.ml

@@ -741,19 +741,12 @@ let tests =
         seq [
           tmp1#set (string "");
           tmp2#set (string "");
-          call [string "eval";
-                output_as_string (
-                  call [string "printf"; string "exec 3> %s"; tmp1#path]
-                )];
           with_redirections (exec ["printf"; "%s"; recognizable]) [
-            to_fd (int 1) (int 2);
-            to_fd (int 2) (int 3);
+            to_file (int 3) tmp1#path;
             to_file (int 3) tmp2#path; (* we hijack tmp1's use of fd 3 *)
+            to_fd (int 2) (int 3);
+            to_fd (int 1) (int 2);
           ];
-          call [string "eval";
-                output_as_string (
-                  call [string "printf"; string "exec 3>&-"]
-                )];
           call [string "cat"; tmp1#path];
           call [string "cat"; tmp2#path];
           assert_or_fail "fd3-empty" (tmp1#get =$= string "");
@@ -763,6 +756,44 @@ let tests =
           return 3
         ]
       );
+    exits 2 ~name:"redirect-fails" Genspio.EDSL.(
+        let tmp1 = tmp_file "fd3" in
+        let tmp2 = tmp_file "return" in
+        let recognizable = "heelllloooooo" in
+        let this_is_bash =
+          (exec ["ps"] |> output_as_string)
+          >> exec ["grep"; "bash"]
+          |> returns ~value:0 in
+        seq [
+          tmp1#set (string "");
+          write_output
+            ~return_value:tmp2#path (
+            with_redirections (exec ["printf"; "%s"; recognizable]) [
+              to_fd (int 4) (int 3); (* This fails because &3 is not open! *)
+              to_file (int 1) tmp1#path;
+            ]
+          );
+          call [string "printf"; string "%s:\\n"; tmp1#path];
+          call [string "cat"; tmp1#path];
+          call [string "printf"; string "%s:\\n"; tmp2#path];
+          call [string "cat"; tmp2#path];
+          assert_or_fail "fd3" (
+            (tmp1#get =$= string "")
+            |||
+            (this_is_bash
+             &&&
+             (tmp1#get =$= string recognizable))
+          );
+          assert_or_fail "return-value" (
+            (tmp2#get =$= string "2")
+            |||
+            (this_is_bash
+             &&&
+             (tmp2#get =$= string "0"))
+          );
+          return 2
+        ]
+      );
   ]
 
 let posix_sh_tests = [