generalise the sandbox

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 = {
@@ -221,56 +221,14 @@ module Make (Raw_store : S.STORE) (Sandbox : S.SANDBOX) = struct
       | `Shell shell ->
         k ~base ~context:{context with shell}
 
-  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 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 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);
         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 ->
+        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/dune

@@ -2,4 +2,4 @@
   (name obuilder)
   (public_name obuilder)
   (preprocess (pps ppx_sexp_conv))
-  (libraries lwt lwt.unix fmt yojson tar-unix sexplib sqlite3 astring logs sha obuilder-spec))
+  (libraries lwt lwt.unix fmt yojson tar-unix sexplib sqlite3 astring logs sha obuilder-spec cmdliner))

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

@@ -1,4 +1,5 @@
 open Lwt.Infix
+open Sexplib.Conv
 
 let ( / ) = Filename.concat
 
@@ -8,6 +9,10 @@ type t = {
   arches : string list;
 }
 
+type config = {
+  fast_sync : bool;
+} [@@deriving sexp]
+
 let get_machine () =
   let ch = Unix.open_process_in "uname -m" in
   let arch = input_line ch in
@@ -93,7 +98,7 @@ module Json_config = struct
     ] else [
     ]
 
-  let seccomp_policy t =
+  let seccomp_policy (t : t) =
     let fields = [
       "defaultAction", `String "SCMP_ACT_ALLOW";
       "syscalls", `List (seccomp_syscalls ~fast_sync:t.fast_sync);
@@ -270,15 +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 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
@@ -296,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
@@ -329,9 +325,25 @@ let clean_runc dir =
       Os.sudo ["runc"; "--root"; dir; "delete"; item]
     )
 
-let create ?(fast_sync=false) ~runc_state_dir () =
-  Os.ensure_dir runc_state_dir;
+let create ~state_dir (c : config) =
+  Os.ensure_dir state_dir;
   let arches = get_arches () in
   Log.info (fun f -> f "Architectures for multi-arch system: %a" Fmt.(Dump.list string) arches);
-  clean_runc runc_state_dir >|= fun () ->
-  { runc_state_dir; fast_sync; arches }
+  clean_runc state_dir >|= fun () -> 
+  { runc_state_dir = state_dir; fast_sync = c.fast_sync; arches }
+
+open Cmdliner 
+
+let fast_sync =
+  Arg.value @@
+  Arg.opt Arg.bool false @@
+  Arg.info
+    ~doc:"Ignore sync syscalls (requires runc >= 1.0.0-rc92)"
+    ~docv:"FAST_SYNC"
+    ["fast-sync"]
+
+let cmdliner : config Term.t = 
+  let make fast_sync = 
+    { fast_sync }
+  in
+  Term.(const make $ fast_sync)

lib/runc_sandbox.mli

@@ -2,10 +2,13 @@
 
 include S.SANDBOX
 
-val create : ?fast_sync:bool -> runc_state_dir:string -> unit -> t Lwt.t
-(** [create dir] is a runc sandboxing system that keeps state in [dir].
-    @param fast_sync Use seccomp to skip all sync syscalls. This is fast (and
-                     safe, since we discard builds after a crash), but requires
-                     runc version 1.0.0-rc92 or later. Note that the runc version
-                     is not the same as the spec version. If "runc --version"
-                     only prints the spec version, then it's too old. *)
+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] is a runc sandboxing system that keeps state in [state_dir]
+    and is configured using [config]. *)

lib/s.ml

@@ -108,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
 
@@ -15,10 +16,10 @@ let log tag msg =
   | `Note -> Fmt.pr "%a@." Fmt.(styled (`Fg `Yellow) string) msg
   | `Output -> output_string stdout msg; flush stdout
 
-let create_builder ?fast_sync spec =
+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 ~runc_state_dir:(Store.state_dir store / "runc") ?fast_sync () >|= fun sandbox ->
+  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)
 
@@ -28,9 +29,10 @@ let read_whole_file path =
   let len = in_channel_length ic in
   really_input_string ic len
 
-let build fast_sync store spec src_dir secrets =
+
+let build store spec conf src_dir secrets =
   Lwt_main.run begin
-    create_builder ~fast_sync store >>= fun (Builder ((module Builder), builder)) ->
+    create_builder store conf >>= fun (Builder ((module Builder), builder)) ->
     let spec =
       try Obuilder.Spec.t_of_sexp (Sexplib.Sexp.load_sexp spec)
       with Failure msg ->
@@ -51,11 +53,11 @@ let build fast_sync store spec src_dir secrets =
       exit 1
   end
 
-let healthcheck fast_sync verbose store =
+let healthcheck verbose store conf =
   if verbose then
     Logs.Src.set_level Obuilder.log_src (Some Logs.Info);
   Lwt_main.run begin
-    create_builder ~fast_sync store >>= fun (Builder ((module Builder), builder)) ->
+    create_builder store conf >>= fun (Builder ((module Builder), builder)) ->
     Builder.healthcheck builder >|= function
     | Error (`Msg m) ->
       Fmt.epr "Healthcheck failed: %s@." m;
@@ -64,9 +66,9 @@ let healthcheck fast_sync verbose store =
       Fmt.pr "Healthcheck passed@."
   end
 
-let delete store id =
+let delete store conf id =
   Lwt_main.run begin
-    create_builder store >>= fun (Builder ((module Builder), builder)) ->
+    create_builder store conf >>= fun (Builder ((module Builder), builder)) ->
     Builder.delete builder id ~log:(fun id -> Fmt.pr "Removing %s@." id)
   end
 
@@ -113,13 +115,6 @@ let id =
     ~docv:"ID"
     []
 
-let fast_sync =
-  Arg.value @@
-  Arg.flag @@
-  Arg.info
-    ~doc:"Ignore sync syscalls (requires runc >= 1.0.0-rc92)"
-    ["fast-sync"]
-
 let secrets =
   (Arg.value @@
    Arg.(opt_all (pair ~sep:':' string file)) [] @@
@@ -130,12 +125,12 @@ let secrets =
 
 let build =
   let doc = "Build a spec file." in
-  Term.(const build $ fast_sync $ store $ spec_file $ src_dir $ secrets),
+  Term.(const build $ store $ spec_file $ Sandbox.cmdliner $ src_dir $ secrets),
   Term.info "build" ~doc
 
 let delete =
   let doc = "Recursively delete a cached build result." in
-  Term.(const delete $ store $ id),
+  Term.(const delete $ store $ Sandbox.cmdliner $ id),
   Term.info "delete" ~doc
 
 let buildkit =
@@ -159,7 +154,7 @@ let verbose =
 
 let healthcheck =
   let doc = "Perform a self-test" in
-  Term.(const healthcheck $ fast_sync $ verbose $ store),
+  Term.(const healthcheck $ verbose $ store $ Sandbox.cmdliner),
   Term.info "healthcheck" ~doc
 
 let cmds = [build; delete; dockerfile; healthcheck]