Record log output from docker pull

lib/build.ml

@@ -189,35 +189,39 @@ module Make (Raw_store : S.STORE) (Sandbox : S.SANDBOX) = struct
           | Some _ as pair -> pair
       )
 
-  let with_container base fn =
-    Os.pread ["docker"; "create"; "--"; base] >>= fun cid ->
-    let cid = String.trim cid in
+  let copy_to_log ~src ~dst =
+    let buf = Bytes.create 4096 in
+    let rec aux () =
+      Lwt_unix.read src buf 0 (Bytes.length buf) >>= function
+      | 0 -> Lwt.return_unit
+      | n -> Build_log.write dst (Bytes.sub_string buf 0 n) >>= aux
+    in
+    aux ()
+
+  let with_container ~log base fn =
+    Os.with_pipe_from_child (fun ~r ~w ->
+        (* We might need to do a pull here, so log the output to show progress. *)
+        let copy = copy_to_log ~src:r ~dst:log in
+        Os.pread ~stderr:(`FD_move_safely w) ["docker"; "create"; "--"; base] >>= fun cid ->
+        copy >|= fun () ->
+        String.trim cid
+      ) >>= fun cid ->
     Lwt.finalize
       (fun () -> fn cid)
       (fun () -> Os.exec ["docker"; "rm"; "--"; cid])
 
   let get_base t ~log base =
     log `Heading (Fmt.strf "(from %a)" Sexplib.Sexp.pp_hum (Atom base));
     let id = Sha256.to_hex (Sha256.string base) in
-    Store.build t.store ~id ~log (fun ~cancelled:_ ~log:_ tmp ->
+    Store.build t.store ~id ~log (fun ~cancelled:_ ~log tmp ->
         Log.info (fun f -> f "Base image not present; importing %S...@." base);
         let rootfs = tmp / "rootfs" in
         Os.sudo ["mkdir"; "--mode=755"; "--"; rootfs] >>= fun () ->
         (* Lwt_process.exec ("", [| "docker"; "pull"; "--"; base |]) >>= fun _ -> *)
-        with_container base (fun cid ->
-            let r, w = Unix.pipe ~cloexec:true () in
-            let exporter, tar =
-              Fun.protect
-                (fun () ->
-                   let exporter = Os.exec ~stdout:(`FD_copy w) ["docker"; "export"; "--"; cid] in
-                   let tar = Os.sudo ~stdin:(`FD_copy r) ["tar"; "-C"; rootfs; "-xf"; "-"] in
-                   exporter, tar
-                )
-                ~finally:(fun () ->
-                    Unix.close r;
-                    Unix.close w
-                  )
-            in
+        with_container ~log base (fun cid ->
+            Os.with_pipe_between_children @@ fun ~r ~w ->
+            let exporter = Os.exec ~stdout:(`FD_move_safely w) ["docker"; "export"; "--"; cid] in
+            let tar = Os.sudo ~stdin:(`FD_move_safely r) ["tar"; "-C"; rootfs; "-xf"; "-"] in
             exporter >>= fun () ->
             tar
           ) >>= fun () ->

lib/os.ml

@@ -5,6 +5,23 @@ type env = (string * string) list [@@deriving sexp]
 
 let ( >>!= ) = Lwt_result.bind
 
+type unix_fd = {
+  raw : Unix.file_descr;
+  mutable needs_close : bool;
+}
+
+let close fd =
+  assert (fd.needs_close);
+  Unix.close fd.raw;
+  fd.needs_close <- false
+
+let ensure_closed_unix fd =
+  if fd.needs_close then close fd
+
+let ensure_closed_lwt fd =
+  if Lwt_unix.state fd = Lwt_unix.Closed then Lwt.return_unit
+  else Lwt_unix.close fd
+
 let pp_signal f x =
   let open Sys in
   if x = sigkill then Fmt.string f "kill"
@@ -13,8 +30,28 @@ let pp_signal f x =
 
 let pp_cmd = Fmt.box Fmt.(list ~sep:sp (quote string))
 
+let redirection = function
+  | `FD_move_safely x -> `FD_copy x.raw
+  | `Dev_null -> `Dev_null
+
+let close_redirection (x : [`FD_move_safely of unix_fd | `Dev_null]) =
+  match x with
+  | `FD_move_safely x -> ensure_closed_unix x
+  | `Dev_null -> ()
+
+(* stdin, stdout and stderr are copied to the child and then closed on the host.
+   They are closed at most once, so duplicates are OK. *)
 let default_exec ?cwd ?stdin ?stdout ?stderr ~pp argv =
-  Lwt_process.exec ?cwd ?stdin ?stdout ?stderr argv >|= function
+  let proc =
+    let stdin  = Option.map redirection stdin in
+    let stdout = Option.map redirection stdout in
+    let stderr = Option.map redirection stderr in
+    Lwt_process.exec ?cwd ?stdin ?stdout ?stderr argv
+  in
+  Option.iter close_redirection stdin;
+  Option.iter close_redirection stdout;
+  Option.iter close_redirection stderr;
+  proc >|= function
   | Unix.WEXITED n -> Ok n
   | Unix.WSIGNALED x -> Fmt.error_msg "%t failed with signal %d" pp x
   | Unix.WSTOPPED x -> Fmt.error_msg "%t stopped with signal %a" pp pp_signal x
@@ -58,23 +95,6 @@ let write_file ~path contents =
   Lwt_io.(with_file ~mode:output) path @@ fun ch ->
   Lwt_io.write ch contents
 
-type unix_fd = {
-  raw : Unix.file_descr;
-  mutable needs_close : bool;
-}
-
-let close fd =
-  assert (fd.needs_close);
-  Unix.close fd.raw;
-  fd.needs_close <- false
-
-let ensure_closed_unix fd =
-  if fd.needs_close then close fd
-
-let ensure_closed_lwt fd =
-  if Lwt_unix.state fd = Lwt_unix.Closed then Lwt.return_unit
-  else Lwt_unix.close fd
-
 let with_pipe_from_child fn =
   let r, w = Lwt_unix.pipe_in () in
   let w = { raw = w; needs_close = true } in
@@ -101,10 +121,21 @@ let with_pipe_to_child fn =
        ensure_closed_lwt w
     )
 
-let pread argv =
+let with_pipe_between_children fn =
+  let r, w = Unix.pipe ~cloexec:true () in
+  let r = { raw = r; needs_close = true } in
+  let w = { raw = w; needs_close = true } in
+  Lwt.finalize
+    (fun () -> fn ~r ~w)
+    (fun () ->
+       ensure_closed_unix r;
+       ensure_closed_unix w;
+       Lwt.return_unit
+    )
+
+let pread ?stderr argv =
   with_pipe_from_child @@ fun ~r ~w ->
-  let child = exec ~stdout:(`FD_copy w.raw) argv in
-  close w;
+  let child = exec ~stdout:(`FD_move_safely w) ?stderr argv in
   let r = Lwt_io.(of_fd ~mode:input) r in
   Lwt.finalize
     (fun () -> Lwt_io.read r)

lib/runc_sandbox.ml

@@ -273,16 +273,14 @@ let run ~cancelled ?stdin:stdin ~log t config results_dir =
   incr next_id;
   Os.with_pipe_from_child @@ fun ~r:out_r ~w:out_w ->
   let cmd = ["runc"; "--root"; t.runc_state_dir; "run"; id] in
-  let stdout = `FD_copy out_w.raw in
+  let stdout = `FD_move_safely out_w in
   let stderr = stdout in
   let copy_log = copy_to_log ~src:out_r ~dst:log in
   let proc =
-    let stdin = Option.map (fun x -> `FD_copy x.Os.raw) stdin in
+    let stdin = Option.map (fun x -> `FD_move_safely x) stdin in
     let pp f = Os.pp_cmd f config.argv in
     Os.sudo_result ~cwd:tmp ?stdin ~stdout ~stderr ~pp cmd
   in
-  Os.close out_w;
-  Option.iter Os.close stdin;
   Lwt.on_termination cancelled (fun () ->
       let rec aux () =
         if Lwt.is_sleeping proc then (

lib_spec/spec.ml

@@ -133,7 +133,7 @@ let pp_op_sexp f : Sexplib.Sexp.t -> unit = function
     Fmt.pf f "(%a @[<v>%a@])"
       Sexplib.Sexp.pp_hum op
       (Fmt.list ~sep:Fmt.sp pp_one_line) args
-  | x -> Sexplib.Sexp.pp_hum f x
+  | x -> pp_one_line f x
 
 let pp_stage f t =
   match sexp_of_stage t with

test/mock_exec.ml

@@ -15,8 +15,9 @@ let base_tar =
 
 let with_fd x f =
   match x with
-  | `FD_copy fd ->
-    let copy = Unix.dup ~cloexec:true fd in
+  | `FD_move_safely fd ->
+    let copy = Unix.dup ~cloexec:true fd.Os.raw in
+    Os.close fd;
     Lwt.finalize
       (fun () -> f copy)
       (fun () -> Unix.close copy; Lwt.return ())
@@ -60,7 +61,21 @@ let mkdir = function
   | ["--mode=755"; "--"; path] -> Unix.mkdir path 0o755; Lwt_result.return 0
   | x -> Fmt.failwith "Unexpected mkdir %a" Fmt.(Dump.list string) x
 
-let exec ?cwd ?stdin ?stdout ?stderr:_ ~pp = function
+let closing redir fn =
+  Lwt.finalize fn
+    (fun () ->
+       begin match redir with
+         | Some (`FD_move_safely fd) -> Os.ensure_closed_unix fd
+         | _ -> ()
+       end;
+       Lwt.return_unit
+    )
+
+let exec ?cwd ?stdin ?stdout ?stderr ~pp cmd =
+  closing stdin @@ fun () ->
+  closing stdout @@ fun () ->
+  closing stderr @@ fun () ->
+  match cmd with
   | ("", argv) ->
     Fmt.pr "exec: %a@." Fmt.(Dump.array string) argv;
     begin match Array.to_list argv with