[WIP] Docker backend: implement copy using streamed tarballs

I had implemented copy using a temporary volume. I believe streaming
tarballs has the following advantages over volumes:
- it doesn't touch the file system, all operations are in-memory;
- renaming the files to their destination is much more reliable (no
  need for escaping).

Author: MisterDA

copy.spec

@@ -0,0 +1,12 @@
+((build dev
+  ((from ocaml/opam@sha256:116c960addbbda19190d47b49e42310916cf42fe432fa5e37eb6104c488218d6)
+   (workdir /src)
+   (run (shell "sudo chown opam /src"))
+   (user (uid 1000) (gid 1000))                           ; Build as the "opam" user
+   ; (copy (src obuilder.opam) (dst ./))
+   (run (shell "echo hello > obuilder.opam"))
+  ))
+ (from debian:10)
+ (copy (from (build dev))
+  (src /src/obuilder.opam)
+  (dst /chabada)))

dune-project

@@ -17,7 +17,8 @@
   (fmt (>= 0.8.9))
   logs
   cmdliner
-  tar-unix
+  (tar (>= 1.2))
+  (tar-unix (>= 1.2))
   yojson
   sexplib
   ppx_deriving

lib/build.ml

@@ -393,24 +393,37 @@ module Docker = struct
     | [item] -> Ok (`Copy_item (item, dst))
     | _ -> Fmt.error_msg "When copying multiple items, the destination must end with '/'"
 
+  let tarball_from_context ~src_dir op user ~to_untar =
+    Log.debug (fun f -> f "tarball_from_context");
+    (* If the sending thread finishes (or fails), close the writing
+       socket immediately so that the tar process finishes too. *)
+    (* Lwt.finalize *)
+    (*   (fun () -> *)
+    match op with
+    | `Copy_items (src_manifest, dst_dir) ->
+      Tar_transfer.send_files ~src_dir ~src_manifest ~dst_dir ~to_untar ~user
+    | `Copy_item (src_manifest, dst) ->
+      Tar_transfer.send_file ~src_dir ~src_manifest ~dst ~to_untar ~user(* ) *)
+  (* (fun () -> Lwt_unix.close to_untar) *)
+
   let mount_point_inside_unix = if Sys.win32 then "/cygdrive/c" else "/var/lib/obuilder"
   let mount_point_inside_native = if Sys.win32 then {|C:\|} else mount_point_inside_unix
 
-  let docker_manifest_from_build ~base ~exclude src user =
+  let manifest_from_build ~base ~exclude src workdir user =
     let obuilder_volume = Docker.obuilder_volume () in
     let docker_argv = [
       "--mount"; Printf.sprintf "type=volume,src=%s,dst=%s,readonly" obuilder_volume (mount_point_inside_native / obuilder_volume);
       "--entrypoint"; if Sys.win32 then mount_point_inside_native / obuilder_volume / "bash.exe" else "bash";
       "--env"; Printf.sprintf "PATH=%s" (if Sys.win32 then mount_point_inside_unix // obuilder_volume else "/bin:/usr/bin");
-      "--workdir"; if Sys.win32 then {|C:\|} else "/";
+      "--workdir"; workdir;
       "--user"; match user with `Unix { Obuilder_spec.uid; gid } -> Printf.sprintf "%d:%d" uid gid | `Windows { Obuilder_spec.name } -> name
       (* FIXME: we don't have access to isolation type here. *)
     ] in
     let manifest_bash =
       (* FIXME: does Filename.quote always use Bash quoting rules? *)
       Printf.sprintf "exec %s %S %S %d %s %d %s"
         (mount_point_inside_unix // obuilder_volume // "manifest.bash")
-        "."
+        workdir
         "/"
         (List.length exclude)
         (String.concat " " (List.map Filename.quote exclude))
@@ -421,96 +434,79 @@ module Docker = struct
     let pp f = Os.pp_cmd f ["Generating source manifest"] in
     Docker.run_pread_result ~pp ~rm:true docker_argv (Docker.docker_image base) argv >>!= fun manifests ->
     match Parsexp.Many.parse_string manifests with
-    | Ok ts -> List.rev_map Manifest.t_of_sexp ts |> Lwt.return |> Lwt_result.ok
+    | Ok ts -> List.rev_map Manifest.t_of_sexp ts |> Lwt_result.return
     | Error e -> Lwt_result.fail (`Msg (Parsexp.Parse_error.message e))
 
-  let docker_tarball_from_context ~src_dir mount_point op user =
-    let name = if Sys.win32 then mount_point / "archive.tar" else Filename.temp_file "obuilder-" "" in
-    Log.debug (fun f -> f "docker_tarball_from_context name:%s" name);
-    Lwt_unix.openfile name [O_WRONLY; O_CREAT] 0o600 >>= fun to_untar ->
-    (* If the sending thread finishes (or fails), close the writing socket
-       immediately so that the tar process finishes too. *)
-    Lwt.finalize
-      (fun () ->
-         Lwt.try_bind
-           (fun () ->
-              match op with
-              | `Copy_items (src_manifest, dst_dir) ->
-                Tar_transfer.send_files ~src_dir ~src_manifest ~dst_dir ~to_untar ~user
-              | `Copy_item (src_manifest, dst) ->
-                Tar_transfer.send_file ~src_dir ~src_manifest ~dst ~to_untar ~user)
-           (fun () ->
-              Lwt_unix.close to_untar >>= fun () ->
-              if not (Sys.win32) then Os.sudo ["cp"; "--"; name; mount_point / "archive.tar"]
-              else Lwt.return_unit)
-           (fun exn -> Lwt_unix.close to_untar >>= fun () -> Lwt.fail exn))
-      (fun () -> if not (Sys.win32) then Lwt_unix.unlink name else Lwt.return_unit)
-
-  let docker_tar_transfer ~dst op ch =
-    let copy_root dst acc t =
-      (* FIXME: escape dst, src, path for regexp? *)
-      begin match t with
-        | `File (path, _) | `Symlink (path, _) ->
-          Lwt_io.fprint ch path >>= fun () ->
-          Lwt.return ("--transform" :: (Printf.sprintf "s,^%s$,%s," path dst) :: acc)
-        | `Dir (src, _) as dir ->
-          Lwt_io.fprint ch (String.concat "\n" (Manifest.to_list dir)) >>= fun () ->
-          Lwt.return ("--transform" :: (Printf.sprintf "s,^%s,%s," (Filename.dirname src) dst) :: acc)
-      end >>= fun tar_argv -> Lwt_io.fprint ch "\n" >>= fun () -> Lwt.return tar_argv
+  let manifest_files_from op fd =
+    let copy_root manifest =
+       let list = Manifest.to_from_files ~null:true manifest in
+       Os.write_all_string fd list 0 (String.length list)
     in
     match op with
-    | `Copy_items (src_manifest, _) -> begin Lwt_list.fold_left_s (copy_root dst) [] src_manifest end
-    | `Copy_item (src_manifest, _) -> begin copy_root dst [] (src_manifest:Manifest.t) end
+    | `Copy_items (src_manifest, _) -> Lwt_list.iter_s copy_root src_manifest
+    | `Copy_item (src_manifest, _) -> copy_root src_manifest
 
-  let docker_tarball_from_build t ~log ~dst ~from (`Docker_volume volume) mount_point op user =
+  let tarball_from_build t ~files_from ~to_untar workdir user id =
     Log.debug (fun f -> f "docker_tarball_from_build");
-    begin
-      let name = mount_point / "manifest" in
-      if Sys.win32 then Lwt_io.with_file ~mode:Output name (docker_tar_transfer ~dst op)
-      else Lwt_io.with_temp_file (fun (tmp, ch) ->
-          docker_tar_transfer ~dst op ch >>= fun tar_argv ->
-          Os.sudo ["cp"; "-a"; "--"; tmp; name] >>= fun () ->
-          Lwt.return tar_argv)
-    end >>= fun tar_argv ->
     let argv =
       ["--login"; "-c";
        String.concat " "
          ([ if Sys.win32 then "tar.exe" else "tar";
-            "-cf"; mount_point_inside_unix // volume // "archive.tar";
-            "--absolute-names"; "--no-recursion";
-            "--show-transformed-names"; "-v"; (* for debugging *)
-            "--files-from"; mount_point_inside_unix // volume // "manifest" ]
-          @ tar_argv)]
+            "-c"; "--format=ustar";
+            "--directory"; workdir;
+            (* Beware, the order is meaningfull: --files-from should come last. *)
+            "--verbatim-files-from"; "--null"; "--absolute-names"; "--files-from=-";
+            "-f-"])]
     in
     let config =
       let obuilder_volume = Docker.obuilder_volume () in
       Config.v
-        ~cwd:(if Sys.win32 then {|C:\|} else "/")
+        ~cwd:workdir
         ~argv
         ~hostname
         ~user
         ~env:["PATH", if Sys.win32 then mount_point_inside_unix // obuilder_volume else "/bin:/usr/bin"]
         ~mount_secrets:[]
         ~mounts:Config.Mount.[
-            {src = volume; dst = mount_point_inside_native / volume; readonly = false};
             {src = obuilder_volume; dst = mount_point_inside_native / obuilder_volume; readonly = true}]
         ~network:[]
         ~entrypoint:(if Sys.win32 then mount_point_inside_native / obuilder_volume / "bash.exe" else "/bin/bash")
         ()
     in
-    let from_tmp = Docker.docker_image ~tmp:true from in
-    Docker.tag (Docker.docker_image from) from_tmp >>= fun () ->
-    (* Bypass db_store. *)
-    let cancelled, set_cancelled = Lwt.wait () in
-    Lwt.finalize
-      (fun () ->
-         Lwt_result.bind_lwt
-           (Docker_sandbox.run ~cancelled ~log t.sandbox config from)
-           (fun () -> docker_teardown_sandbox from ~commit:false))
-      (fun () ->
-         Docker.image "rm" from_tmp >>= fun () ->
-         Lwt.wakeup_later set_cancelled ();
-         Lwt.return_unit)
+    let docker_args, args = Docker_sandbox.Docker_config.make config ~config_dir:"" (* unused *) t in
+    Docker.run ~stdin:(`FD_move_safely files_from) ~stdout:(`FD_move_safely to_untar)
+      ~rm:true docker_args (Docker.docker_image id) args
+
+  let untar t ~cancelled ~stdin ~log workdir id =
+    let obuilder_volume = Docker.obuilder_volume () in
+    let mounts =
+      if Sys.win32 then [Config.Mount.{
+          src = obuilder_volume;
+          dst = mount_point_inside_native / obuilder_volume;
+          readonly = true; }]
+      else []
+    in
+    let entrypoint =
+      if Sys.win32 then Printf.sprintf {|C:\%s\tar.exe|} obuilder_volume
+      else "/usr/bin/env" in
+    let argv = ["-xf"; "-"; "--absolute-names"; ]
+               |> if not Sys.win32 then List.cons "tar" else Fun.id
+    in
+    let config = Config.v
+        ~cwd:workdir
+        ~argv
+        ~hostname
+        ~user:Obuilder_spec.root
+        ~env:[]
+        ~mount_secrets:[]
+        ~mounts
+        ~network:[]
+        ~entrypoint
+        ()
+    in
+    Lwt_result.bind_lwt
+      (Docker_sandbox.run ~cancelled ~stdin ~log t.sandbox config id)
+      (fun () -> docker_teardown_sandbox id ~commit:true)
 
   let copy t ~context ~base { Obuilder_spec.from; src; dst; exclude } =
     let { Context.switch; src_dir; workdir; user; log; shell = _; env = _; scope; secrets = _ } = context in
@@ -526,11 +522,11 @@ module Docker = struct
           | None ->
             Lwt_result.fail (`Msg (Fmt.str "Build result %S not found" id))
           | Some dir ->
-            Lwt_result.return (`Build (id, dir / "rootfs"))
+            Lwt_result.return (`Build (id, dir))
     end >>!= fun src_dir ->
     begin match src_dir with
       | `Context src_dir -> sequence (List.map (Manifest.generate ~exclude ~src_dir) src) |> Lwt.return
-      | `Build (id, _) -> docker_manifest_from_build ~base:id ~exclude src user
+      | `Build (id, _) -> manifest_from_build ~base:id ~exclude src workdir user
     end >>= fun src_manifest ->
     match Result.bind src_manifest (to_copy_op ~dst) with
     | Error _ as e -> Lwt.return e
@@ -543,53 +539,37 @@ module Docker = struct
       Log.debug (fun f -> f "COPY: %a@." Sexplib.Sexp.pp_hum (sexp_of_copy_details details));
       let id = Sha256.to_hex (Sha256.string (Sexplib.Sexp.to_string (sexp_of_copy_details details))) in
       Store.build t.store ?switch ~base ~id ~log (fun ~cancelled ~log _ ->
-          let volume = Docker.docker_volume_copy id in
-          Docker.volume ["create"] volume >>= fun _ ->
-          Lwt.finalize
-            (fun () ->
-               Docker.mount_point volume >>= fun mount_point ->
-               Log.debug (fun f -> f "Generating tarball");
-               begin match src_dir with
-                 | `Context src_dir -> docker_tarball_from_context ~src_dir mount_point op user |> Lwt_result.ok
-                 | `Build (from, _) -> docker_tarball_from_build t ~log ~dst ~from volume mount_point op user
-               end >>!= fun () ->
-               let argv = ["-xf"; mount_point_inside_unix // id // "archive.tar"; "--absolute-names";
-                           "-v" (* for debugging *) ]
-                          |> if not Sys.win32 then List.cons "tar" else Fun.id
-               in
-               let config =
-                 let obuilder_volume = Docker.obuilder_volume () in
-                 let mounts =
-                   [ Config.Mount.{
-                         src = Docker.volume_copy_name id;
-                         dst = mount_point_inside_native / id;
-                         readonly = false }]
-                   |> if Sys.win32 then List.cons Config.Mount.{
-                       src = obuilder_volume;
-                       dst = mount_point_inside_native / obuilder_volume;
-                       readonly = true; }
-                   else Fun.id
-                 in
-                 let entrypoint =
-                   if Sys.win32 then Printf.sprintf {|C:\%s\tar.exe|} obuilder_volume
-                   else "/usr/bin/env" in
-                 Config.v
-                   ~cwd:(if Sys.win32 then {|C:\|} else "/")
-                   ~argv
-                   ~hostname
-                   ~user:Obuilder_spec.root
-                   ~env:[]
-                   ~mount_secrets:[]
-                   ~mounts
-                   ~network:[]
-                   ~entrypoint
-                   ()
-               in
-               Log.debug (fun f -> f "Docker_sandbox is running");
-               Lwt_result.bind_lwt
-                 (Docker_sandbox.run ~cancelled ~log t.sandbox config id)
-                 (fun () -> docker_teardown_sandbox id ~commit:true))
-            (fun () -> Docker.volume ["rm"] volume >>= fun _ -> Lwt.return_unit))
+          Log.debug (fun f -> f "Produce the tar stream");
+          (* let dbgout = Os.{raw = Unix.openfile "/tmp/ocaml.tar" [O_WRONLY;O_CREAT;O_TRUNC] 0o666; needs_close = false} in *)
+          (* Lwt_unix.openfile "/tmp/ocaml.tar" [O_WRONLY;O_CREAT;O_TRUNC] 0o666 >>= fun dbgout -> *)
+          Os.with_pipe_between_children @@ fun ~r:from_tar ~w:to_untar -> begin
+            begin match src_dir with
+              | `Context src_dir ->
+                Log.debug (fun f -> f "… from build context");
+                tarball_from_context ~src_dir op user ~to_untar:(Lwt_unix.of_unix_file_descr to_untar.raw)
+              | `Build (id, _dir) ->
+                Log.debug (fun f -> f "… from build %s" id );
+                Os.with_pipe_to_child @@ fun ~r:files_from_in ~w:files_from_out -> begin
+                  manifest_files_from op files_from_out >>= fun () ->
+                  tarball_from_build t.sandbox ~files_from:files_from_in ~to_untar workdir user id
+                end
+            end >>= fun () -> begin
+              Log.debug (fun f -> f "Rename the files in tar");
+              Os.with_pipe_between_children @@ fun ~r:from_tar' ~w:to_untar -> begin
+                begin
+                  let from_tar = Lwt_unix.of_unix_file_descr from_tar.raw in
+                  let to_untar = Lwt_unix.of_unix_file_descr to_untar.raw in
+                  match op with
+                  | `Copy_items (_, dst_dir) ->
+                    Tar_transfer.transform_files ~dst_dir ~user ~from_tar ~to_untar
+                  | `Copy_item (_, dst) ->
+                    Tar_transfer.transform_file ~dst ~user ~from_tar ~to_untar
+                end >>= fun () ->
+                Log.debug (fun f -> f "Untar");
+                untar t ~cancelled ~log ~stdin:from_tar' workdir id
+              end
+            end
+          end)
 
   let pp_op ~(context:Context.t) f op =
     Fmt.pf f "@[<v2>%s: %a@]" context.workdir Obuilder_spec.pp_op op

lib/docker.ml

@@ -84,13 +84,14 @@ let build docker_argv (`Docker_image image) context_path =
 let run ?stdin ?stdout ?stderr ?name ?(rm=false) docker_argv (`Docker_image image) argv =
   let docker_argv = if rm then "--rm" :: docker_argv else docker_argv in
   let docker_argv = Option.fold ~none:docker_argv ~some:(fun (`Docker_container name) -> "--name" :: name :: docker_argv) name in
+  let docker_argv = match stdin with Some (`FD_move_safely _) -> "-i" :: docker_argv | _ -> docker_argv in
   let argv = docker_argv @ image :: argv in
   exec' ?stdin ?stdout ?stderr ("run" :: argv)
 
 let run_result ?stdin ~pp ?name ?(rm=false) docker_argv (`Docker_image image) argv =
   let docker_argv = if rm then "--rm" :: docker_argv else docker_argv in
   let docker_argv = Option.fold ~none:docker_argv ~some:(fun (`Docker_container name) -> "--name" :: name :: docker_argv) name in
-  let docker_argv = if Option.is_some stdin then "-i" :: docker_argv else docker_argv in
+  let docker_argv = match stdin with Some (`FD_move_safely _) -> "-i" :: docker_argv | _ -> docker_argv in
   let argv = docker_argv @ image :: argv in
   exec_result' ?stdin ~pp ("run" :: argv)
 

lib/manifest.ml

@@ -66,10 +66,12 @@ let generate ~exclude ~src_dir src =
     with Failure m ->
       Error (`Msg m)
 
-let to_list t =
-  let rec aux l = function
-    | `File (name, _hash) -> name :: l
-    | `Symlink (name, _target) -> name :: l
-    | `Dir (name, entries) -> name :: List.fold_left aux l entries
+let to_from_files ?(null=false) t =
+  let sep = if null then '\000' else '\n' in
+  let buf = Buffer.create 64 in
+  let rec aux = function
+    | `File (name, _) | `Symlink (name, _) -> Buffer.add_string buf name; Buffer.add_char buf sep
+    | `Dir (name, entries) -> Buffer.add_string buf name; Buffer.add_char buf sep; List.iter aux entries
   in
-  aux [] t
+  aux t;
+  Buffer.contents buf

lib/manifest.mli

@@ -10,4 +10,6 @@ val generate : exclude:string list -> src_dir:string -> string -> (t, [> `Msg of
     Files with basenames in [exclude] are ignored.
     Returns an error if [src] is not under [src_dir] or does not exist. *)
 
-val to_list : t -> string list
+val to_from_files : ?null:bool -> t -> string
+(** [to_from_files t] returns a buffer containing the list of files,
+   separated by ASCII LF (the default) or NUL if [null] is true. *)

lib/os.ml

@@ -6,7 +6,7 @@ type unix_fd = {
   raw : Unix.file_descr;
   mutable needs_close : bool;
 }
-
+    
 let close fd =
   assert (fd.needs_close);
   Unix.close fd.raw;
@@ -26,7 +26,7 @@ let pp_signal f x =
   else Fmt.int 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
@@ -93,6 +93,14 @@ let rec write_all fd buf ofs len =
     write_all fd buf (ofs + n) (len - n)
   )
 
+let rec write_all_string fd buf ofs len =
+  assert (len >= 0);
+  if len = 0 then Lwt.return_unit
+  else (
+    Lwt_unix.write_string fd buf ofs len >>= fun n ->
+    write_all_string fd buf (ofs + n) (len - n)
+  )
+
 let write_file ~path contents =
   Lwt_io.(with_file ~mode:output) path @@ fun ch ->
   Lwt_io.write ch contents
@@ -135,6 +143,15 @@ let with_pipe_between_children fn =
        Lwt.return_unit
     )
 
+(* let with_lwt_pipe_between_children_result f g = *)
+(*   let r, w = Lwt_unix.pipe () in *)
+(*   Lwt.finalize *)
+(*     (fun () -> Lwt_result.both (f ~w) (g ~r)) *)
+(*     (fun () -> *)
+(*        ensure_closed_lwt r >>= fun () -> *)
+(*        ensure_closed_lwt w *)
+(*     ) *)
+
 let pread ?stderr argv =
   with_pipe_from_child @@ fun ~r ~w ->
   let child = exec ~stdout:(`FD_move_safely w) ?stderr argv in