Pick the Docker 'sandbox' when the Docker store is chosen

lib/build.ml

@@ -318,8 +318,8 @@ module Make (Raw_store : S.STORE) (Sandbox : S.SANDBOX) (Fetch : S.FETCHER) = st
     Lwt.return_unit
 end
 
-module Docker = struct
-  module Store = Db_store.Make(Docker_store)
+module Make_Docker (Raw_store : S.STORE) = struct
+  module Store = Db_store.Make(Raw_store)
 
   type t = {
     store : Store.t;

lib/build.mli

@@ -28,8 +28,8 @@ module Make (Store : S.STORE) (Sandbox : S.SANDBOX) (_ : S.FETCHER) : sig
   val v : store:Store.t -> sandbox:Sandbox.t -> t
 end
 
-module Docker : sig
+module Make_Docker (Store : S.STORE) : sig
   include S.BUILDER with type context := Context.t
 
-  val v : store:Docker_store.t -> sandbox:Docker_sandbox.t -> t
+  val v : store:Store.t -> sandbox:Docker_sandbox.t -> t
 end

lib/docker_sandbox.mli

@@ -56,6 +56,6 @@ val cmdliner : config Cmdliner.Term.t
     necessary flags and parameters to setup a specific sandbox's
     configuration. *)
 
-val create : ?clean:bool -> config -> t Lwt.t
+val create : config -> t Lwt.t
 (** [create config] is a Docker sandboxing system that is configured
     using [config]. *)

lib/docker_store.mli

@@ -2,6 +2,6 @@
 
 include S.STORE
 
-val create : ?clean:bool -> string -> t Lwt.t
+val create : string -> t Lwt.t
 (** [create root] is a new store using Docker images and [root] to store
     ancillary state. *)

lib/obuilder.ml

@@ -27,7 +27,7 @@ module Docker_sandbox = Docker_sandbox
 
 module type BUILDER = S.BUILDER with type context := Build.Context.t
 module Builder = Build.Make
-module Docker_builder = Build.Docker
+module Docker_builder = Build.Make_Docker
 module Build_log = Build_log
 
 (**/**)

lib/store_spec.ml

@@ -6,6 +6,7 @@ type t = [
   | `Btrfs of string  (* Path *)
   | `Zfs of string    (* Pool *)
   | `Rsync of string  (* Path for the root of the store *)
+  | `Docker of string (* Path *)
 ]
 
 let is_absolute path = not (Filename.is_relative path)
@@ -15,25 +16,30 @@ let of_string s =
   | Some ("zfs", pool) -> Ok (`Zfs pool)
   | Some ("btrfs", path) when is_absolute path -> Ok (`Btrfs path)
   | Some ("rsync", path) when is_absolute path -> Ok (`Rsync path)
+  | Some ("docker", path) -> Ok (`Docker path)
   | _ -> Error (`Msg "Store must start with zfs: or btrfs:/ or rsync:/")
 
 let pp f = function
   | `Zfs pool -> Fmt.pf f "zfs:%s" pool
   | `Btrfs path -> Fmt.pf f "btrfs:%s" path
   | `Rsync path -> Fmt.pf f "rsync:%s" path
+  | `Docker path -> Fmt.pf f "docker:%s" path
 
 type store = Store : (module S.STORE with type t = 'a) * 'a -> store
 
 let to_store rsync_mode = function
   | `Btrfs path ->
-    Btrfs_store.create path >|= fun store ->
+    `Runc, Btrfs_store.create path >|= fun store ->
     Store ((module Btrfs_store), store)
   | `Zfs pool ->
-    Zfs_store.create ~pool >|= fun store ->
+    `Runc, Zfs_store.create ~pool >|= fun store ->
     Store ((module Zfs_store), store)
   | `Rsync path ->
-    Rsync_store.create ~path ~mode:rsync_mode () >|= fun store ->
+    `Runc, Rsync_store.create ~path ~mode:rsync_mode () >|= fun store ->
     Store ((module Rsync_store), store)
+  | `Docker path ->
+    `Docker, Docker_store.create path >|= fun store ->
+    Store ((module Docker_store), store)
 
 open Cmdliner
 

main.ml

@@ -7,7 +7,6 @@ module Docker_sandbox = Obuilder.Docker_sandbox
 module Docker_store = Obuilder.Docker_store
 module Docker_extract = Obuilder.Docker_extract
 module Store_spec = Obuilder.Store_spec
-module Docker_builder = Obuilder.Docker_builder
 
 type builder = Builder : (module Obuilder.BUILDER with type t = 'a) * 'a -> builder
 
@@ -17,40 +16,34 @@ let log tag msg =
   | `Note -> Fmt.pr "%a@." Fmt.(styled (`Fg `Yellow) string) msg
   | `Output -> output_string stdout msg; flush stdout
 
-let create_builder spec conf =
-  spec >>= fun (Store_spec.Store ((module Store), store)) ->
+let create_builder store_spec conf =
+  store_spec >>= fun (Store_spec.Store ((module Store), store)) ->
   let module Builder = Obuilder.Builder (Store) (Runc_sandbox) (Docker_extract) in
   Runc_sandbox.create ~state_dir:(Store.state_dir store / "sandbox") conf >|= fun sandbox ->
   let builder = Builder.v ~store ~sandbox in
   Builder ((module Builder), builder)
 
-let create_docker_builder path clean conf =
-  let module Builder = Docker_builder in
-  Docker_store.create ~clean path >>= fun store ->
-  Docker_sandbox.create ~clean conf >|= fun sandbox ->
-  let builder = Docker_builder.v ~store ~sandbox in
-  Builder ((module Docker_builder), builder)
+let create_docker_builder store_spec conf =
+  store_spec >>= fun (Store_spec.Store ((module Store), store)) ->
+  let module Builder = Obuilder.Docker_builder (Store) in
+  Docker_sandbox.create conf >|= fun sandbox ->
+  let builder = Builder.v ~store ~sandbox in
+  Builder ((module Builder), builder)
 
 let read_whole_file path =
   let ic = open_in_bin path in
   Fun.protect ~finally:(fun () -> close_in ic) @@ fun () ->
   let len = in_channel_length ic in
   really_input_string ic len
 
-let select_backend store docker_backend docker_clean runc_conf docker_conf =
-  match store, docker_backend with
-  | None, None ->
-    Fmt.epr "Must select either a store or the Docker backend@.";
-    exit 1
-  | Some _, Some _ ->
-    Fmt.epr "Cannot select a store and the Docker backend@.";
-    exit 1
-  | Some store, None -> create_builder store runc_conf
-  | None, Some path -> create_docker_builder path docker_clean docker_conf
-
-let build () store docker_backend docker_clean spec runc_conf docker_conf src_dir secrets =
+let select_backend (sandbox, store_spec) runc_conf docker_conf =
+  match sandbox with
+  | `Runc -> create_builder store_spec runc_conf
+  | `Docker -> create_docker_builder store_spec docker_conf
+
+let build () store spec runc_conf docker_conf src_dir secrets =
   Lwt_main.run begin
-    select_backend store docker_backend docker_clean runc_conf docker_conf
+    select_backend store runc_conf docker_conf
     >>= fun (Builder ((module Builder), builder)) ->
     Fun.flip Lwt.finalize (fun () -> Builder.finish builder) @@ fun () ->
     let spec =
@@ -73,9 +66,9 @@ let build () store docker_backend docker_clean spec runc_conf docker_conf src_di
       exit 1
   end
 
-let healthcheck () store docker_backend docker_clean runc_conf docker_conf =
+let healthcheck () store runc_conf docker_conf =
   Lwt_main.run begin
-    select_backend store docker_backend docker_clean runc_conf docker_conf
+    select_backend store runc_conf docker_conf
     >>= fun (Builder ((module Builder), builder)) ->
     Fun.flip Lwt.finalize (fun () -> Builder.finish builder) @@ fun () ->
     Builder.healthcheck builder >|= function
@@ -86,9 +79,9 @@ let healthcheck () store docker_backend docker_clean runc_conf docker_conf =
       Fmt.pr "Healthcheck passed@."
   end
 
-let delete () store docker_backend docker_clean runc_conf docker_conf id =
+let delete () store runc_conf docker_conf id =
   Lwt_main.run begin
-    select_backend store docker_backend docker_clean runc_conf docker_conf
+    select_backend store runc_conf docker_conf
     >>= fun (Builder ((module Builder), builder)) ->
     Fun.flip Lwt.finalize (fun () -> Builder.finish builder) @@ fun () ->
     Builder.delete builder id ~log:(fun id -> Fmt.pr "Removing %s@." id)
@@ -113,8 +106,6 @@ let setup_log =
   let docs = Manpage.s_common_options in
   Term.(const setup_log $ Fmt_cli.style_renderer ~docs () $ Logs_cli.level ~docs ())
 
-let docs_docker = "DOCKER BACKEND"
-
 let spec_file =
   Arg.required @@
   Arg.opt Arg.(some file) None @@
@@ -133,24 +124,6 @@ let src_dir =
 
 let store = Store_spec.cmdliner
 
-let docker_backend =
-  Arg.value @@
-  Arg.opt Arg.(some string) None @@
-  Arg.info
-    ~doc:"Use the Docker store and sandbox backend. Use $(docv) for temporary files."
-    ~docv:"PATH"
-    ~docs:docs_docker
-    ["docker-backend"]
-
-let docker_clean =
-  Arg.value @@
-  Arg.flag @@
-  Arg.info
-    ~doc:"Cleans the Docker store (see $(b,--docker-backend)) and sandbox data \
-          (images,  containers, volumes) at startup."
-    ~docs:docs_docker
-    ["docker-clean"]
-
 let id =
   Arg.required @@
   Arg.pos 0 Arg.(some string) None @@
@@ -171,15 +144,15 @@ let build =
   let doc = "Build a spec file." in
   let info = Cmd.info ~doc "build" in
   Cmd.v info
-    Term.(const build $ setup_log $ store $ docker_backend $ docker_clean $ spec_file
-          $ Obuilder.Runc_sandbox.cmdliner $ Obuilder.Docker_sandbox.cmdliner $ src_dir $ secrets)
+    Term.(const build $ setup_log $ store $ spec_file $ Runc_sandbox.cmdliner
+          $ Docker_sandbox.cmdliner $ src_dir $ secrets)
 
 let delete =
   let doc = "Recursively delete a cached build result." in
   let info = Cmd.info ~doc "delete" in
   Cmd.v info
-    Term.(const delete $ setup_log $ store $ docker_backend $ docker_clean
-          $ Runc_sandbox.cmdliner $ Docker_sandbox.cmdliner $ id)
+    Term.(const delete $ setup_log $ store $ Runc_sandbox.cmdliner
+          $ Docker_sandbox.cmdliner $ id)
 
 let buildkit =
   Arg.value @@
@@ -207,8 +180,8 @@ let healthcheck =
   let doc = "Perform a self-test." in
   let info = Cmd.info ~doc "healthcheck" in
   Cmd.v info
-    Term.(const healthcheck $ setup_log $ store $ docker_backend $ docker_clean
-          $ Runc_sandbox.cmdliner $ Docker_sandbox.cmdliner)
+    Term.(const healthcheck $ setup_log $ store $ Runc_sandbox.cmdliner
+          $ Docker_sandbox.cmdliner)
 
 let cmds = [build; delete; dockerfile; healthcheck]
 

stress/stress.ml

@@ -212,9 +212,8 @@ module Test(Store : S.STORE) = struct
     aux ()
 end
 
-let stress spec conf =
+let stress (_, spec) conf =
   Lwt_main.run begin
-    let spec = Option.get spec in
     spec >>= fun (Store_spec.Store ((module Store), store)) ->
     let module T = Test(Store) in
     T.test_store store >>= fun () ->