separate sandboxing from base image fetching

lib/build.ml

@@ -42,7 +42,7 @@ module Saved_context = struct
   } [@@deriving sexp]
 end
 
-module Make (Raw_store : S.STORE) (Sandbox : S.SANDBOX) = struct
+module Make (Raw_store : S.STORE) (Sandbox : S.SANDBOX) (Fetch : S.FETCHER) = struct
   module Store = Db_store.Make(Raw_store)
 
   type t = {
@@ -226,7 +226,9 @@ module Make (Raw_store : S.STORE) (Sandbox : S.SANDBOX) = struct
     let id = Sha256.to_hex (Sha256.string base) in
     Store.build t.store ~id ~log (fun ~cancelled:_ ~log tmp ->
         Log.info (fun f -> f "Base image not present; importing %S..." base);
-        Sandbox.from ~log ~base tmp >>= fun env -> 
+        let rootfs = tmp / "rootfs" in
+        Os.sudo ["mkdir"; "--mode=755"; "--"; rootfs] >>= fun () ->
+        Fetch.fetch ~log ~rootfs base >>= fun env -> 
         Os.write_file ~path:(tmp / "env")
           (Sexplib.Sexp.to_string_hum Saved_context.(sexp_of_t {env})) >>= fun () ->
         Lwt_result.return ()

lib/build.mli

@@ -22,7 +22,7 @@ module Context : sig
   *)
 end
 
-module Make (Store : S.STORE) (Sandbox : S.SANDBOX) : sig
+module Make (Store : S.STORE) (Sandbox : S.SANDBOX) (Fetch : S.FETCHER) : sig
   include S.BUILDER with type context := Context.t
 
   val v : store:Store.t -> sandbox:Sandbox.t -> t

lib/build_log.ml

@@ -112,3 +112,12 @@ let empty = {
   state = `Empty;
   len = 0;
 }
+
+let copy ~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 -> write dst (Bytes.sub_string buf 0 n) >>= aux
+  in
+  aux ()

lib/build_log.mli

@@ -31,3 +31,9 @@ val tail : ?switch:Lwt_switch.t -> t -> (string -> unit) -> (unit, [> `Cancelled
 (** [tail t dst] streams data from the log to [dst].
     This can be called at any time before [finish] is called.
     @param switch Abort if this is turned off. *)
+
+(* {2 Copying to logs} *)
+
+val copy : src:Lwt_unix.file_descr -> dst:t -> unit Lwt.t
+(** [copy ~src ~dst] reads bytes from the [src] file descriptor and
+    writes them to the build log [dst]. *)

lib/docker.ml

@@ -0,0 +1,37 @@
+open Lwt.Infix
+
+let export_env base : Config.env Lwt.t =
+  Os.pread ["docker"; "image"; "inspect";
+            "--format"; {|{{range .Config.Env}}{{print . "\x00"}}{{end}}|};
+            "--"; base] >|= fun env ->
+  String.split_on_char '\x00' env
+  |> List.filter_map (function
+      | "\n" -> None
+      | kv ->
+        match Astring.String.cut ~sep:"=" kv with
+        | None -> Fmt.failwith "Invalid environment in Docker image %S (should be 'K=V')" kv
+        | Some _ as pair -> pair
+    )
+
+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 = Build_log.copy ~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 ~stdout:`Dev_null ["docker"; "rm"; "--"; cid])
+
+
+let fetch ~log ~rootfs base =  
+  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 () -> 
+  export_env base

lib/docker.mli

@@ -0,0 +1,3 @@
+(** Fetching of base images using Docker *)
+
+include S.FETCHER

lib/obuilder.ml

@@ -12,6 +12,9 @@ module Btrfs_store = Btrfs_store
 module Zfs_store = Zfs_store
 module Store_spec = Store_spec
 
+(** {2 Fetchers} *)
+module Docker = Docker
+
 (** {2 Sandboxes} *)
 
 module Config = Config

lib/runc_sandbox.ml

@@ -275,54 +275,6 @@ end
 
 let next_id = ref 0
 
-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 export_env base : Config.env Lwt.t =
-  Os.pread ["docker"; "image"; "inspect";
-            "--format"; {|{{range .Config.Env}}{{print . "\x00"}}{{end}}|};
-            "--"; base] >|= fun env ->
-  String.split_on_char '\x00' env
-  |> List.filter_map (function
-      | "\n" -> None
-      | kv ->
-        match Astring.String.cut ~sep:"=" kv with
-        | None -> Fmt.failwith "Invalid environment in Docker image %S (should be 'K=V')" kv
-        | Some _ as pair -> pair
-    )
-
-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 ~stdout:`Dev_null ["docker"; "rm"; "--"; cid])
-
-let from ~log ~base 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 ~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 () ->
-  export_env base
-
 let run ~cancelled ?stdin:stdin ~log t config results_dir =
   Lwt_io.with_temp_dir ~perm:0o700 ~prefix:"obuilder-runc-" @@ fun tmp ->
   let json_config = Json_config.make config ~config_dir:tmp ~results_dir t in
@@ -340,7 +292,7 @@ let run ~cancelled ?stdin:stdin ~log t config results_dir =
   let cmd = ["runc"; "--root"; t.runc_state_dir; "run"; id] 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 copy_log = Build_log.copy ~src:out_r ~dst:log in
   let proc =
     let stdin = Option.map (fun x -> `FD_move_safely x) stdin in
     let pp f = Os.pp_cmd f config.argv in

lib/s.ml

@@ -64,17 +64,6 @@ end
 module type SANDBOX = sig
   type t
 
-  val from : 
-    log:Build_log.t ->
-    base:string ->
-    string -> 
-    Config.env Lwt.t
-  (** [from ~log ~base tmp] should fetch the [base] image and configure it in [tmp] returning
-      a set of environmenet variables.
-      @param log Used for writing logs.
-      @param base The base template to build a new sandbox from (e.g. docker image hash).
-  *)
-
   val run :
     cancelled:unit Lwt.t ->
     ?stdin:Os.unix_fd ->
@@ -119,3 +108,12 @@ module type BUILDER = sig
       @param timeout Cancel and report failure after this many seconds.
                      This excludes the time to fetch the base image. *)
 end
+
+module type FETCHER = sig 
+  val fetch : log:Build_log.t -> rootfs:string -> string -> Config.env Lwt.t
+  (** [fetch ~log ~rootfs base] initialises the [rootfs] directory by
+      fetching and extracting the [base] image. 
+      Returns the image's environment. 
+      @param log Used for outputting the progress of the fetch 
+      @param rootfs The directory in which to extract the base image *)
+end 

main.ml

@@ -6,6 +6,7 @@ let () =
 let ( / ) = Filename.concat
 
 module Sandbox = Obuilder.Runc_sandbox
+module Fetcher = Obuilder.Docker
 
 type builder = Builder : (module Obuilder.BUILDER with type t = 'a) * 'a -> builder
 
@@ -17,7 +18,7 @@ let log tag msg =
 
 let create_builder spec conf =
   Obuilder.Store_spec.to_store spec >>= fun (Store ((module Store), store)) -> 
-  let module Builder = Obuilder.Builder(Store)(Sandbox) in
+  let module Builder = Obuilder.Builder(Store)(Sandbox)(Fetcher) in
   Sandbox.create ~state_dir:(Store.state_dir store / "sandbox") conf >|= fun sandbox ->
   let builder = Builder.v ~store ~sandbox in
   Builder ((module Builder), builder)

stress/stress.ml

@@ -17,6 +17,7 @@ let assert_str expected got =
   )
 
 module Sandbox = Runc_sandbox
+module Fetcher = Docker
 
 module Test(Store : S.STORE) = struct
   let assert_output expected t id =
@@ -104,7 +105,7 @@ module Test(Store : S.STORE) = struct
       assert (x = Ok ());
       Lwt.return_unit
 
-  module Build = Builder(Store)(Sandbox)
+  module Build = Builder(Store)(Sandbox)(Fetcher)
 
   let n_steps = 4
   let n_values = 3

test/mock_sandbox.ml

@@ -11,8 +11,6 @@ type t = {
 
 let expect t x = Queue.add x t.expect
 
-let from = Obuilder.Runc_sandbox.from
-
 let run ~cancelled ?stdin ~log t (config:Obuilder.Config.t) dir =
   match Queue.take_opt t.expect with
   | None -> Fmt.failwith "Unexpected sandbox execution: %a" Fmt.(Dump.list string) config.argv

test/test.ml

@@ -1,7 +1,7 @@
 open Lwt.Infix
 open Obuilder
 
-module B = Builder(Mock_store)(Mock_sandbox)
+module B = Builder(Mock_store)(Mock_sandbox)(Docker)
 
 let ( / ) = Filename.concat
 let ( >>!= ) = Lwt_result.bind