reuse get-base with sandbox-specifc from function

lib/build.ml

@@ -221,7 +221,22 @@ module Make (Raw_store : S.STORE) (Sandbox : S.SANDBOX) = struct
       | `Shell shell ->
         k ~base ~context:{context with shell}
 
-  let rec build ~scope t context { Obuilder_spec.child_builds; from; ops } =
+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 ->
+      Log.info (fun f -> f "Base image not present; importing %S..." base);
+      Sandbox.from ~log ~base tmp >>!= fun env -> 
+      Os.write_file ~path:(tmp / "env")
+        (Sexplib.Sexp.to_string_hum Saved_context.(sexp_of_t {env})) >>= fun () ->
+      Lwt_result.return ()
+    )
+  >>!= fun id ->
+  let path = Option.get (Store.result t.store id) in
+  let { Saved_context.env } = Saved_context.t_of_sexp (Sexplib.Sexp.load_sexp (path / "env")) in
+  Lwt_result.return (id, env)
+
+  let rec build ~scope t context { Obuilder_spec.child_builds; from = base; ops } =
     let rec aux context = function
       | [] -> Lwt_result.return context
       | (name, child_spec) :: child_builds ->
@@ -232,18 +247,7 @@ module Make (Raw_store : S.STORE) (Sandbox : S.SANDBOX) = struct
         aux context child_builds
     in
     aux context child_builds >>!= fun context ->
-    let log = context.Context.log in 
-    let id = Sha256.to_hex (Sha256.string from) in
-    let f = Sandbox.from ~from ~log t.sandbox in 
-      (Store.build t.store ~id ~log f >>!= fun id -> 
-        (match Store.result t.store id with 
-        | Some path -> 
-            if Sys.file_exists @@ path / "env" then begin 
-              let { Saved_context.env } = Saved_context.t_of_sexp (Sexplib.Sexp.load_sexp (path / "env")) in
-              Lwt_result.return (id, env)
-            end else Lwt_result.return (id, [])
-        | None -> Lwt_result.return (id, [])))
-      >>!= fun (id, env) ->
+    get_base t ~log:context.Context.log base >>!= fun (id, env) ->
     let context = { context with env = context.env @ env } in
     run_steps t ~context ~base:id ops
 
@@ -277,12 +281,7 @@ module Make (Raw_store : S.STORE) (Sandbox : S.SANDBOX) = struct
     (* Get the base image first, before starting the timer. *)
     let switch = Lwt_switch.create () in
     let context = Context.v ~switch ~log ~src_dir:"/tmp" () in
-    let id = Sha256.to_hex (Sha256.string healthcheck_base) in
-    let f = Sandbox.from ~from:healthcheck_base ~log t.sandbox in 
-    (Store.build t.store ~id ~log f >>!= fun id -> 
-      let path = Option.get (Store.result t.store id) in
-      let { Saved_context.env } = Saved_context.t_of_sexp (Sexplib.Sexp.load_sexp (path / "env")) in
-      Lwt_result.return (id, env)) >>= function
+    get_base t ~log healthcheck_base >>= function
     | Error (`Msg _) as x -> Lwt.return x
     | Error `Cancelled -> failwith "Cancelled getting base image (shouldn't happen!)"
     | Ok (id, env) ->

lib/runc_sandbox.ml

@@ -315,26 +315,22 @@ let with_container ~log base fn =
     (fun () -> fn cid)
     (fun () -> Os.exec ~stdout:`Dev_null ["docker"; "rm"; "--"; cid])
 
-let from ~log ~from _t =
-  let base = from in 
-  log `Heading (Fmt.strf "(from %a)" Sexplib.Sexp.pp_hum (Atom base));
-  (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 ~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 >>= fun env ->
-      Os.write_file ~path:(tmp / "env")
-        (Sexplib.Sexp.to_string_hum Saved_context.(sexp_of_t {env})) >>= fun () ->
-      Lwt_result.return ()
-    )
+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 >>= fun env ->
+  Os.write_file ~path:(tmp / "env")
+    (Sexplib.Sexp.to_string_hum Saved_context.(sexp_of_t {env})) >>= fun () ->
+  Lwt_result.return env
 
 let run ~cancelled ?stdin:stdin ~log t config results_dir =
   Lwt_io.with_temp_dir ~prefix:"obuilder-runc-" @@ fun tmp ->
@@ -402,7 +398,7 @@ let fast_sync =
   Arg.value @@
   Arg.opt Arg.bool false @@
   Arg.info
-    ~doc:"Install a seccomp filter that skips all synchronous syscalls"
+    ~doc:"Ignore sync syscalls (requires runc >= 1.0.0-rc92)"
     ~docv:"FAST_SYNC"
     ["fast-sync"]
 

lib/runc_sandbox.mli

@@ -2,3 +2,14 @@
 
 include S.SANDBOX
 
+type config [@@deriving sexp]
+(** The type of sandbox configurations *)
+
+val cmdliner : config Cmdliner.Term.t 
+(** [cmdliner] is used for command-line interfaces to generate the necessary flags 
+    and parameters to setup a specific sandbox's configuration. *)
+
+val create : ?state_dir:string -> config -> t Lwt.t   
+(** [create ?state_dir config] generates a new sandbox -- the state directory is used for 
+    runc environments where the store's state directory can be passed in, otherwise just leave 
+    it out. *)

lib/s.ml

@@ -64,31 +64,15 @@ end
 module type SANDBOX = sig
   type t
 
-  type config [@@deriving sexp]
-  (** The type of sandbox configurations *)
-
-  val cmdliner : config Cmdliner.Term.t 
-  (** [cmdliner] is used for command-line interfaces to generate the necessary flags 
-      and parameters to setup a specific sandbox's configuration. *)
-
-  val create : ?state_dir:string -> config -> t Lwt.t   
-  (** [create ?state_dir config] generates a new sandbox -- the state directory is used for 
-      runc environments where the store's state directory can be passed in, otherwise just leave 
-      it out. *)
-
   val from : 
-    log:logger -> 
-    from:string ->
-    t -> 
-    cancelled:unit Lwt.t ->
     log:Build_log.t ->
-    string -> (unit, [ `Cancelled | `Msg of string ]) result Lwt.t
-  (** [from t ~log ~from_stage] generates the function to be run as the initial build-step 
-      for the sandboxing environment using Obuilder's from stage. 
+    base:string ->
+    string -> 
+    (Config.env, [ `Cancelled | `Msg of string ]) result Lwt.t
+    (** [from ~log ~base tmp] should fetch the [base] image and configure it in [tmp] 
       @param log Used for writing logs.
-      @param from The base template to build a new sandbox from (e.g. docker image hash).
+      @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 ->

main.ml

@@ -18,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
-  Sandbox.create ~state_dir:(Store.state_dir store / "runc") conf >|= fun sandbox ->
+  Sandbox.create ~state_dir:(Store.state_dir store / "sandbox") conf >|= fun sandbox ->
   let builder = Builder.v ~store ~sandbox in
   Builder ((module Builder), builder)
 

test/mock_sandbox.ml

@@ -1,7 +1,3 @@
-open Sexplib.Conv
-open Lwt.Infix
-open Obuilder
-
 type t = {
   dir : string;
   expect :
@@ -13,88 +9,12 @@ type t = {
      (unit, [`Msg of string | `Cancelled]) Lwt_result.t) Queue.t;
 }
 
-type config = {
-  dir : string;
-}[@@deriving sexp]
-
-module Saved_context = struct
-  type t = {
-    env : Config.env;
-  } [@@deriving sexp]
-end
-
-open Cmdliner
-let dir =
-  Arg.required @@
-  Arg.opt Arg.(some file) None @@
-  Arg.info
-    ~doc:"Directory"
-    ~docv:"DIR"
-    ["dir"]
 
-let cmdliner : config Term.t = 
-  let make dir = 
-    { dir }
-  in
-  Term.(const make $ dir)
 
 let expect t x = Queue.add x t.expect
 
-let export_env base =
-  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 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 ~stdout:`Dev_null ["docker"; "rm"; "--"; cid])
-
-let from ~log ~from _t =
-  let ( / ) = Filename.concat in 
-  let base = from in 
-  log `Heading (Fmt.strf "(from %a)" Sexplib.Sexp.pp_hum (Atom base));
-  (fun ~cancelled:_ ~log tmp ->
-      Logs.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 >>= fun env ->
-      Os.write_file ~path:(tmp / "env")
-        (Sexplib.Sexp.to_string_hum Saved_context.(sexp_of_t {env})) >>= fun () ->
-      Lwt_result.return ()
-    )
+let from = Obuilder.Runc_sandbox.from
 
 
 let run ~cancelled ?stdin ~log t (config:Obuilder.Config.t) dir =
@@ -108,6 +28,4 @@ let run ~cancelled ?stdin ~log t (config:Obuilder.Config.t) dir =
         | ex -> Lwt_result.fail (`Msg (Printexc.to_string ex))
       )
 
-let create ?state_dir:_ conf = Lwt.return { dir = conf.dir; expect = Queue.create () }
-
-let mock_create conf = { dir = conf.dir; expect = Queue.create () }
+let create dir = { dir; expect = Queue.create () }

test/mock_sandbox.mli

@@ -1,12 +1,6 @@
-type config = { dir : string } [@@derivign sexp]
-(** Exposing the configuration so testing can generate them rather than 
-    relying on cmdliner *)
-
-include Obuilder.S.SANDBOX with type config := config
-
-val mock_create : config -> t
-(** To simplify test sandbox creation, this is an Lwt free [create] function *)
+include Obuilder.S.SANDBOX
 
+val create : string -> t
 val expect :
   t -> (cancelled:unit Lwt.t ->
         ?stdin:Obuilder.Os.unix_fd ->

test/test.ml

@@ -24,7 +24,7 @@ let get store path id =
 
 let with_config fn =
   Mock_store.with_store @@ fun store ->
-  let sandbox = Mock_sandbox.mock_create { dir = Mock_store.state_dir store / "sandbox" } in
+  let sandbox = Mock_sandbox.create (Mock_store.state_dir store / "sandbox") in
   let builder = B.v ~store ~sandbox in
   let src_dir = Mock_store.state_dir store / "src" in
   Os.ensure_dir src_dir;