From 8225864a6e3daa7e2d54e442145222c179b9bf2f Mon Sep 17 00:00:00 2001 From: patricoferris Date: Mon, 4 Jan 2021 10:54:07 +0000 Subject: [PATCH 1/8] generalise the sandbox --- lib/build.ml | 81 +++++++++---------------------------- lib/dune | 2 +- lib/runc_sandbox.ml | 92 +++++++++++++++++++++++++++++++++++++++---- lib/runc_sandbox.mli | 7 ---- lib/s.ml | 28 +++++++++++++ main.ml | 40 ++++++++----------- stress/stress.ml | 19 ++++----- test/dune | 3 +- test/mock_sandbox.ml | 92 ++++++++++++++++++++++++++++++++++++++++++- test/mock_sandbox.mli | 10 ++++- test/test.ml | 4 +- 11 files changed, 263 insertions(+), 115 deletions(-) diff --git a/lib/build.ml b/lib/build.ml index 6bdf64a5..a825d496 100644 --- a/lib/build.ml +++ b/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) -> diff --git a/lib/dune b/lib/dune index 3a3fd232..c725fd4d 100644 --- a/lib/dune +++ b/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)) diff --git a/lib/runc_sandbox.ml b/lib/runc_sandbox.ml index 5e429eb5..a75d3b95 100644 --- a/lib/runc_sandbox.ml +++ b/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) diff --git a/lib/runc_sandbox.mli b/lib/runc_sandbox.mli index a25277f3..f0f85b48 100644 --- a/lib/runc_sandbox.mli +++ b/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. *) diff --git a/lib/s.ml b/lib/s.ml index 94ee61a9..b70e718e 100644 --- a/lib/s.ml +++ b/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 -> diff --git a/main.ml b/main.ml index 7d6ff5c4..0a0f8653 100644 --- a/main.ml +++ b/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] diff --git a/stress/stress.ml b/stress/stress.ml index 7974232b..d652fa8a 100644 --- a/stress/stress.ml +++ b/stress/stress.ml @@ -16,6 +16,8 @@ let assert_str expected got = exit 1 ) +module Sandbox = Runc_sandbox + module Test(Store : S.STORE) = struct let assert_output expected t id = match Store.result t id with @@ -102,7 +104,6 @@ module Test(Store : S.STORE) = struct assert (x = Ok ()); Lwt.return_unit - module Sandbox = Runc_sandbox module Build = Builder(Store)(Sandbox) let n_steps = 4 @@ -154,8 +155,8 @@ module Test(Store : S.STORE) = struct | Error (`Msg m) -> failwith m | Error `Cancelled -> assert false - let stress_builds store = - Sandbox.create ~runc_state_dir:(Store.state_dir store / "runc") ~fast_sync:true () >>= fun sandbox -> + let stress_builds store conf = + Sandbox.create ~state_dir:(Store.state_dir store / "runc") conf >>= fun sandbox -> let builder = Build.v ~store ~sandbox in let pending = ref n_jobs in let running = ref 0 in @@ -193,8 +194,8 @@ module Test(Store : S.STORE) = struct if !failures > 0 then Fmt.failwith "%d failures!" !failures else Lwt.return_unit - let prune store = - Sandbox.create ~runc_state_dir:(Store.state_dir store / "runc") () >>= fun sandbox -> + let prune store conf = + Sandbox.create ~state_dir:(Store.state_dir store / "runc") conf >>= fun sandbox -> let builder = Build.v ~store ~sandbox in let log id = Logs.info (fun f -> f "Deleting %S" id) in let end_time = Unix.(gettimeofday () +. 60.0 |> gmtime) in @@ -207,14 +208,14 @@ module Test(Store : S.STORE) = struct aux () end -let stress spec = +let stress spec conf = Lwt_main.run begin Store_spec.to_store spec >>= fun (Store ((module Store), store)) -> let module T = Test(Store) in T.test_store store >>= fun () -> T.test_cache store >>= fun () -> - T.stress_builds store >>= fun () -> - T.prune store + T.stress_builds store conf >>= fun () -> + T.prune store conf end open Cmdliner @@ -234,7 +235,7 @@ let store = let cmd = let doc = "Run stress tests." in - Term.(const stress $ store), + Term.(const stress $ store $ Sandbox.cmdliner), Term.info "stress" ~doc let () = diff --git a/test/dune b/test/dune index 24643bec..d70294b9 100644 --- a/test/dune +++ b/test/dune @@ -2,6 +2,7 @@ (name test) (package obuilder) (deps base.tar) - (libraries alcotest-lwt obuilder str)) + (preprocess (pps ppx_sexp_conv)) + (libraries alcotest-lwt obuilder str sexplib)) (dirs :standard \ test1) diff --git a/test/mock_sandbox.ml b/test/mock_sandbox.ml index e899ebb1..2cad27fb 100644 --- a/test/mock_sandbox.ml +++ b/test/mock_sandbox.ml @@ -1,3 +1,7 @@ +open Sexplib.Conv +open Lwt.Infix +open Obuilder + type t = { dir : string; expect : @@ -9,8 +13,92 @@ type t = { (unit, [`Msg of string | `Cancelled]) Lwt_result.t) Queue.t; } +type config = { + dir : string; +}[@@deriving sexp] + +let sandbox_type = "mock" + +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 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 @@ -22,4 +110,6 @@ let run ~cancelled ?stdin ~log t (config:Obuilder.Config.t) dir = | ex -> Lwt_result.fail (`Msg (Printexc.to_string ex)) ) -let create dir = { dir; expect = Queue.create () } +let create ?state_dir:_ conf = Lwt.return { dir = conf.dir; expect = Queue.create () } + +let mock_create conf = { dir = conf.dir; expect = Queue.create () } diff --git a/test/mock_sandbox.mli b/test/mock_sandbox.mli index eaaf9fb9..ca9baae3 100644 --- a/test/mock_sandbox.mli +++ b/test/mock_sandbox.mli @@ -1,6 +1,12 @@ -include Obuilder.S.SANDBOX +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 *) -val create : string -> t val expect : t -> (cancelled:unit Lwt.t -> ?stdin:Obuilder.Os.unix_fd -> diff --git a/test/test.ml b/test/test.ml index 72d28977..515d2d32 100644 --- a/test/test.ml +++ b/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.create (Mock_store.state_dir store / "sandbox") in + let sandbox = Mock_sandbox.mock_create { dir = 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; @@ -668,7 +668,7 @@ let () = test_case "Cancel 3" `Quick test_cancel_3; test_case "Cancel 4" `Quick test_cancel_4; test_case "Cancel 5" `Quick test_cancel_5; - test_case "Delete" `Quick test_delete; + test_case "Delete" `Quick test_delete; ]; "secrets", [ test_case "Simple" `Quick test_secrets_simple; From e5e519e993ef4444ac9d9e700cedb122b2c6a254 Mon Sep 17 00:00:00 2001 From: patricoferris Date: Mon, 4 Jan 2021 15:54:31 +0000 Subject: [PATCH 2/8] add pp to sandbox --- lib/runc_sandbox.ml | 19 +++++++++++++++++-- lib/s.ml | 4 ++-- test/mock_sandbox.ml | 7 ++++++- 3 files changed, 25 insertions(+), 5 deletions(-) diff --git a/lib/runc_sandbox.ml b/lib/runc_sandbox.ml index a75d3b95..f595ef71 100644 --- a/lib/runc_sandbox.ml +++ b/lib/runc_sandbox.ml @@ -13,7 +13,22 @@ type config = { fast_sync : bool; } [@@deriving sexp] -let sandbox_type = "runc" +let pp ppf = + let fields = + [ + Fmt.field ~label:Fmt.string "runc_state_dir" + (fun (t : t) -> t.runc_state_dir) + Fmt.string; + Fmt.field ~label:Fmt.string "fast_sync" + (fun (t : t) -> t.fast_sync) + Fmt.bool; + Fmt.field ~label:Fmt.string "arches" + (fun (t : t) -> t.arches) + Fmt.(brackets @@ list ~sep:(fun ppf _ -> Fmt.string ppf ",") string); + ] + in + let r = Fmt.(braces @@ record fields) in + Fmt.(pf ppf "runc state:@, %a" r) let get_machine () = let ch = Unix.open_process_in "uname -m" in @@ -404,7 +419,7 @@ let fast_sync = Arg.value @@ Arg.opt Arg.bool false @@ Arg.info - ~doc:"Install a seccomp filter that skips allsync syscalls" + ~doc:"Install a seccomp filter that skips all synchronous syscalls" ~docv:"FAST_SYNC" ["fast-sync"] diff --git a/lib/s.ml b/lib/s.ml index b70e718e..5c7a5132 100644 --- a/lib/s.ml +++ b/lib/s.ml @@ -64,8 +64,8 @@ end module type SANDBOX = sig type t - val sandbox_type : string - (** A string declaring the type of sandboxing environment *) + val pp : t Fmt.t + (** A pretty-printer for sandbox environments *) type config [@@deriving sexp] (** The type of sandbox configurations *) diff --git a/test/mock_sandbox.ml b/test/mock_sandbox.ml index 2cad27fb..916a462b 100644 --- a/test/mock_sandbox.ml +++ b/test/mock_sandbox.ml @@ -17,7 +17,12 @@ type config = { dir : string; }[@@deriving sexp] -let sandbox_type = "mock" +let pp ppf = + let fields = [ + Fmt.field ~label:Fmt.string "dir" (fun (t : t) -> t.dir) Fmt.string; + ] in + let r = Fmt.(braces @@ record fields) in + Fmt.(pf ppf "mock = %a" r) module Saved_context = struct type t = { From 9ae6b8006b69d2a581521771fae18db7a697003a Mon Sep 17 00:00:00 2001 From: patricoferris Date: Mon, 4 Jan 2021 16:00:17 +0000 Subject: [PATCH 3/8] use fmt comma --- lib/runc_sandbox.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/runc_sandbox.ml b/lib/runc_sandbox.ml index f595ef71..865294f7 100644 --- a/lib/runc_sandbox.ml +++ b/lib/runc_sandbox.ml @@ -24,7 +24,7 @@ let pp ppf = Fmt.bool; Fmt.field ~label:Fmt.string "arches" (fun (t : t) -> t.arches) - Fmt.(brackets @@ list ~sep:(fun ppf _ -> Fmt.string ppf ",") string); + Fmt.(brackets @@ list ~sep:comma string); ] in let r = Fmt.(braces @@ record fields) in From 60eb6422a8c3c5121dcbef5de3f00c0a1c02b949 Mon Sep 17 00:00:00 2001 From: Patrick Ferris Date: Thu, 18 Mar 2021 12:27:18 +0000 Subject: [PATCH 4/8] remove unnecessary pretty-printer --- lib/runc_sandbox.ml | 17 ----------------- lib/s.ml | 3 --- test/mock_sandbox.ml | 7 ------- 3 files changed, 27 deletions(-) diff --git a/lib/runc_sandbox.ml b/lib/runc_sandbox.ml index 865294f7..20d7d704 100644 --- a/lib/runc_sandbox.ml +++ b/lib/runc_sandbox.ml @@ -13,23 +13,6 @@ type config = { fast_sync : bool; } [@@deriving sexp] -let pp ppf = - let fields = - [ - Fmt.field ~label:Fmt.string "runc_state_dir" - (fun (t : t) -> t.runc_state_dir) - Fmt.string; - Fmt.field ~label:Fmt.string "fast_sync" - (fun (t : t) -> t.fast_sync) - Fmt.bool; - Fmt.field ~label:Fmt.string "arches" - (fun (t : t) -> t.arches) - Fmt.(brackets @@ list ~sep:comma string); - ] - in - let r = Fmt.(braces @@ record fields) in - Fmt.(pf ppf "runc state:@, %a" r) - let get_machine () = let ch = Unix.open_process_in "uname -m" in let arch = input_line ch in diff --git a/lib/s.ml b/lib/s.ml index 5c7a5132..d5709dd9 100644 --- a/lib/s.ml +++ b/lib/s.ml @@ -64,9 +64,6 @@ end module type SANDBOX = sig type t - val pp : t Fmt.t - (** A pretty-printer for sandbox environments *) - type config [@@deriving sexp] (** The type of sandbox configurations *) diff --git a/test/mock_sandbox.ml b/test/mock_sandbox.ml index 916a462b..3b62c0dd 100644 --- a/test/mock_sandbox.ml +++ b/test/mock_sandbox.ml @@ -17,13 +17,6 @@ type config = { dir : string; }[@@deriving sexp] -let pp ppf = - let fields = [ - Fmt.field ~label:Fmt.string "dir" (fun (t : t) -> t.dir) Fmt.string; - ] in - let r = Fmt.(braces @@ record fields) in - Fmt.(pf ppf "mock = %a" r) - module Saved_context = struct type t = { env : Config.env; From 25c8f9be6885151fa9742313a1dd086ea5ab9b15 Mon Sep 17 00:00:00 2001 From: Patrick Ferris Date: Thu, 18 Mar 2021 17:19:44 +0000 Subject: [PATCH 5/8] reuse get-base with sandbox-specifc from function --- lib/build.ml | 37 +++++++++---------- lib/runc_sandbox.ml | 38 +++++++++---------- lib/runc_sandbox.mli | 11 ++++++ lib/s.ml | 26 +++---------- main.ml | 2 +- test/mock_sandbox.ml | 86 +------------------------------------------ test/mock_sandbox.mli | 10 +---- test/test.ml | 2 +- 8 files changed, 57 insertions(+), 155 deletions(-) diff --git a/lib/build.ml b/lib/build.ml index a825d496..a45ca6dc 100644 --- a/lib/build.ml +++ b/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) -> diff --git a/lib/runc_sandbox.ml b/lib/runc_sandbox.ml index 20d7d704..11c33207 100644 --- a/lib/runc_sandbox.ml +++ b/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 ~perm:0o700 ~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"] diff --git a/lib/runc_sandbox.mli b/lib/runc_sandbox.mli index f0f85b48..618eca63 100644 --- a/lib/runc_sandbox.mli +++ b/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. *) diff --git a/lib/s.ml b/lib/s.ml index d5709dd9..d43d4aad 100644 --- a/lib/s.ml +++ b/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 -> diff --git a/main.ml b/main.ml index 0a0f8653..703df4cc 100644 --- a/main.ml +++ b/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) diff --git a/test/mock_sandbox.ml b/test/mock_sandbox.ml index 3b62c0dd..157d7bc1 100644 --- a/test/mock_sandbox.ml +++ b/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 () } \ No newline at end of file diff --git a/test/mock_sandbox.mli b/test/mock_sandbox.mli index ca9baae3..eaaf9fb9 100644 --- a/test/mock_sandbox.mli +++ b/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 -> diff --git a/test/test.ml b/test/test.ml index 515d2d32..82f78f0c 100644 --- a/test/test.ml +++ b/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; From 3051f5223fc2b23d285eff1fa89a80e7ca6fa108 Mon Sep 17 00:00:00 2001 From: Patrick Ferris Date: Fri, 19 Mar 2021 10:14:30 +0000 Subject: [PATCH 6/8] reformat and fix env handling --- lib/build.ml | 2 +- lib/runc_sandbox.ml | 11 +---------- lib/s.ml | 6 ++++-- main.ml | 12 ++++++------ test/dune | 3 +-- test/mock_sandbox.ml | 6 +----- test/test.ml | 2 +- 7 files changed, 15 insertions(+), 27 deletions(-) diff --git a/lib/build.ml b/lib/build.ml index a45ca6dc..924c8d7c 100644 --- a/lib/build.ml +++ b/lib/build.ml @@ -226,7 +226,7 @@ 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 -> + 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 () diff --git a/lib/runc_sandbox.ml b/lib/runc_sandbox.ml index 11c33207..e360dc08 100644 --- a/lib/runc_sandbox.ml +++ b/lib/runc_sandbox.ml @@ -32,12 +32,6 @@ 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 [ @@ -327,10 +321,7 @@ let from ~log ~base tmp = 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 + 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 -> diff --git a/lib/s.ml b/lib/s.ml index d43d4aad..f6b79857 100644 --- a/lib/s.ml +++ b/lib/s.ml @@ -68,11 +68,13 @@ module type SANDBOX = sig log:Build_log.t -> 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] + 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 -> diff --git a/main.ml b/main.ml index 703df4cc..fa0563ee 100644 --- a/main.ml +++ b/main.ml @@ -116,11 +116,11 @@ let id = 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 @@ -153,7 +153,7 @@ let verbose = let healthcheck = let doc = "Perform a self-test" in - Term.(const healthcheck $ verbose $ store $ Sandbox.cmdliner), + Term.(const healthcheck $ verbose $ store $ Sandbox.cmdliner), Term.info "healthcheck" ~doc let cmds = [build; delete; dockerfile; healthcheck] diff --git a/test/dune b/test/dune index d70294b9..24643bec 100644 --- a/test/dune +++ b/test/dune @@ -2,7 +2,6 @@ (name test) (package obuilder) (deps base.tar) - (preprocess (pps ppx_sexp_conv)) - (libraries alcotest-lwt obuilder str sexplib)) + (libraries alcotest-lwt obuilder str)) (dirs :standard \ test1) diff --git a/test/mock_sandbox.ml b/test/mock_sandbox.ml index 157d7bc1..09114e88 100644 --- a/test/mock_sandbox.ml +++ b/test/mock_sandbox.ml @@ -9,14 +9,10 @@ type t = { (unit, [`Msg of string | `Cancelled]) Lwt_result.t) Queue.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 @@ -28,4 +24,4 @@ let run ~cancelled ?stdin ~log t (config:Obuilder.Config.t) dir = | ex -> Lwt_result.fail (`Msg (Printexc.to_string ex)) ) -let create dir = { dir; expect = Queue.create () } \ No newline at end of file +let create dir = { dir; expect = Queue.create () } diff --git a/test/test.ml b/test/test.ml index 82f78f0c..72d28977 100644 --- a/test/test.ml +++ b/test/test.ml @@ -668,7 +668,7 @@ let () = test_case "Cancel 3" `Quick test_cancel_3; test_case "Cancel 4" `Quick test_cancel_4; test_case "Cancel 5" `Quick test_cancel_5; - test_case "Delete" `Quick test_delete; + test_case "Delete" `Quick test_delete; ]; "secrets", [ test_case "Simple" `Quick test_secrets_simple; From 0e2eb13597eaf4bcc04d92b655df3bc8bcc88f74 Mon Sep 17 00:00:00 2001 From: Patrick Ferris Date: Fri, 19 Mar 2021 10:25:03 +0000 Subject: [PATCH 7/8] make state directory mandatory --- lib/runc_sandbox.ml | 15 ++++++--------- lib/runc_sandbox.mli | 7 +++---- 2 files changed, 9 insertions(+), 13 deletions(-) diff --git a/lib/runc_sandbox.ml b/lib/runc_sandbox.ml index e360dc08..e7f34b2d 100644 --- a/lib/runc_sandbox.ml +++ b/lib/runc_sandbox.ml @@ -373,15 +373,12 @@ let clean_runc dir = Os.sudo ["runc"; "--root"; dir; "delete"; item] ) -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 } +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 state_dir >|= fun () -> + { runc_state_dir = state_dir; fast_sync = c.fast_sync; arches } open Cmdliner diff --git a/lib/runc_sandbox.mli b/lib/runc_sandbox.mli index 618eca63..50da9eb7 100644 --- a/lib/runc_sandbox.mli +++ b/lib/runc_sandbox.mli @@ -9,7 +9,6 @@ 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 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]. *) From 2ae7425643151a93efb21d63011b3bbe5ad31090 Mon Sep 17 00:00:00 2001 From: Patrick Ferris Date: Mon, 22 Mar 2021 11:57:36 +0000 Subject: [PATCH 8/8] separate sandboxing from base image fetching --- lib/build.ml | 6 ++++-- lib/build.mli | 2 +- lib/build_log.ml | 9 ++++++++ lib/build_log.mli | 6 ++++++ lib/docker.ml | 37 ++++++++++++++++++++++++++++++++ lib/docker.mli | 3 +++ lib/obuilder.ml | 3 +++ lib/runc_sandbox.ml | 50 +------------------------------------------- lib/s.ml | 20 ++++++++---------- main.ml | 3 ++- stress/stress.ml | 3 ++- test/mock_sandbox.ml | 2 -- test/test.ml | 2 +- 13 files changed, 78 insertions(+), 68 deletions(-) create mode 100644 lib/docker.ml create mode 100644 lib/docker.mli diff --git a/lib/build.ml b/lib/build.ml index 924c8d7c..470701ed 100644 --- a/lib/build.ml +++ b/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 () diff --git a/lib/build.mli b/lib/build.mli index 2059919a..5f94b364 100644 --- a/lib/build.mli +++ b/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 diff --git a/lib/build_log.ml b/lib/build_log.ml index 662592e8..fdb602fe 100644 --- a/lib/build_log.ml +++ b/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 () diff --git a/lib/build_log.mli b/lib/build_log.mli index 5bd365c0..23c88136 100644 --- a/lib/build_log.mli +++ b/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]. *) diff --git a/lib/docker.ml b/lib/docker.ml new file mode 100644 index 00000000..32dd889e --- /dev/null +++ b/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 diff --git a/lib/docker.mli b/lib/docker.mli new file mode 100644 index 00000000..1738c712 --- /dev/null +++ b/lib/docker.mli @@ -0,0 +1,3 @@ +(** Fetching of base images using Docker *) + +include S.FETCHER diff --git a/lib/obuilder.ml b/lib/obuilder.ml index a47f08a3..05a75448 100644 --- a/lib/obuilder.ml +++ b/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 diff --git a/lib/runc_sandbox.ml b/lib/runc_sandbox.ml index e7f34b2d..b8f9d526 100644 --- a/lib/runc_sandbox.ml +++ b/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 diff --git a/lib/s.ml b/lib/s.ml index f6b79857..95c1f140 100644 --- a/lib/s.ml +++ b/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 diff --git a/main.ml b/main.ml index fa0563ee..9d89d680 100644 --- a/main.ml +++ b/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) diff --git a/stress/stress.ml b/stress/stress.ml index d652fa8a..628f636d 100644 --- a/stress/stress.ml +++ b/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 diff --git a/test/mock_sandbox.ml b/test/mock_sandbox.ml index 09114e88..e899ebb1 100644 --- a/test/mock_sandbox.ml +++ b/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 diff --git a/test/test.ml b/test/test.ml index 72d28977..4df34243 100644 --- a/test/test.ml +++ b/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