generalise the sandbox

Author: patricoferris

lib/build.ml

@@ -221,66 +221,7 @@ 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 ->
-        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 build ~scope t context { Obuilder_spec.child_builds; from; ops } =
     let rec aux context = function
       | [] -> Lwt_result.return context
       | (name, child_spec) :: child_builds ->
@@ -291,7 +232,18 @@ module Make (Raw_store : S.STORE) (Sandbox : S.SANDBOX) = struct
         aux context child_builds
     in
     aux context child_builds >>!= fun context ->
-    get_base t ~log:context.Context.log base >>!= fun (id, env) ->
+    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) ->
     let context = { context with env = context.env @ env } in
     run_steps t ~context ~base:id ops
 
@@ -325,7 +277,12 @@ 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
-    get_base t ~log healthcheck_base >>= function
+    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
     | Error (`Msg _) as x -> Lwt.return x
     | Error `Cancelled -> failwith "Cancelled getting base image (shouldn't happen!)"
     | Ok (id, env) ->

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/runc_sandbox.ml

@@ -1,4 +1,5 @@
 open Lwt.Infix
+open Sexplib.Conv
 
 let ( / ) = Filename.concat
 
@@ -8,6 +9,12 @@ type t = {
   arches : string list;
 }
 
+type config = {
+  fast_sync : bool;
+} [@@deriving sexp]
+
+let sandbox_type = "runc"
+
 let get_machine () =
   let ch = Unix.open_process_in "uname -m" in
   let arch = input_line ch in
@@ -27,6 +34,12 @@ let get_arches () =
 
 let secret_file id = "secret-" ^ string_of_int id
 
+module Saved_context = struct
+  type t = {
+    env : Config.env;
+  } [@@deriving sexp]
+end
+
 module Json_config = struct
   let mount ?(options=[]) ~ty ~src dst =
     `Assoc [
@@ -93,7 +106,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);
@@ -279,6 +292,52 @@ let copy_to_log ~src ~dst =
   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 ~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 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
@@ -329,9 +388,28 @@ 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 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 }
+let create ?state_dir (c : config) =
+  match state_dir with 
+    | None -> Fmt.failwith "Runc requires a state directory"
+    | Some runc_state_dir -> 
+        Os.ensure_dir runc_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 = c.fast_sync; arches }
+
+open Cmdliner 
+
+let fast_sync =
+  Arg.value @@
+  Arg.opt Arg.bool false @@
+  Arg.info
+    ~doc:"Install a seccomp filter that skips allsync syscalls"
+    ~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,3 @@
 
 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. *)

lib/s.ml

@@ -64,6 +64,34 @@ end
 module type SANDBOX = sig
   type t
 
+  val sandbox_type : string
+  (** A string declaring the type of sandboxing environment *)
+
+  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. 
+      @param log Used for writing logs.
+      @param from 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

@@ -15,10 +15,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 ->
+  Sandbox.create ~state_dir:(Store.state_dir store / "runc") conf >|= fun sandbox ->
   let builder = Builder.v ~store ~sandbox in
   Builder ((module Builder), builder)
 
@@ -28,9 +28,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 +52,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 +65,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,29 +114,22 @@ 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)) [] @@
-   Arg.info
-     ~doc:"Provide a secret under the form id:file"
-     ~docv:"SECRET"
-     ["secret"])
+    Arg.(opt_all (pair ~sep:':' string file)) [] @@
+    Arg.info
+      ~doc:"Provide a secret under the form id:file"
+      ~docv:"SECRET"
+      ["secret"])
 
 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 +153,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]