diff --git a/lib/build.ml b/lib/build.ml index 6bdf64a5..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 = { @@ -221,40 +221,6 @@ 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 @@ -262,15 +228,7 @@ module Make (Raw_store : S.STORE) (Sandbox : S.SANDBOX) = struct 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 () 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/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/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 5e429eb5..b8f9d526 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,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) diff --git a/lib/runc_sandbox.mli b/lib/runc_sandbox.mli index a25277f3..50da9eb7 100644 --- a/lib/runc_sandbox.mli +++ b/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]. *) diff --git a/lib/s.ml b/lib/s.ml index 94ee61a9..95c1f140 100644 --- a/lib/s.ml +++ b/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 diff --git a/main.ml b/main.ml index 7d6ff5c4..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 @@ -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] diff --git a/stress/stress.ml b/stress/stress.ml index 7974232b..628f636d 100644 --- a/stress/stress.ml +++ b/stress/stress.ml @@ -16,6 +16,9 @@ let assert_str expected got = exit 1 ) +module Sandbox = Runc_sandbox +module Fetcher = Docker + module Test(Store : S.STORE) = struct let assert_output expected t id = match Store.result t id with @@ -102,8 +105,7 @@ module Test(Store : S.STORE) = struct assert (x = Ok ()); Lwt.return_unit - module Sandbox = Runc_sandbox - module Build = Builder(Store)(Sandbox) + module Build = Builder(Store)(Sandbox)(Fetcher) let n_steps = 4 let n_values = 3 @@ -154,8 +156,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 +195,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 +209,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 +236,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/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