diff --git a/lib/btrfs_store.ml b/lib/btrfs_store.ml index 370b21d7..3a6a5cd4 100644 --- a/lib/btrfs_store.ml +++ b/lib/btrfs_store.ml @@ -132,7 +132,7 @@ let create root = purge (root / "cache-tmp") >>= fun () -> Lwt.return { root; caches = Hashtbl.create 10; next = 0 } -let build t ?base ~id fn = +let build t ?base ~id ~meta:_ fn = let result = Path.result t id in let result_tmp = Path.result_tmp t id in assert (not (Sys.file_exists result)); (* Builder should have checked first *) diff --git a/lib/build.ml b/lib/build.ml index 8e2414a7..0f80e123 100644 --- a/lib/build.ml +++ b/lib/build.ml @@ -70,17 +70,20 @@ module Make (Raw_store : S.STORE) (Sandbox : S.SANDBOX) (Fetch : S.FETCHER) = st shell : string list; network : string list; mount_secrets : Config.Secret.t list; + rom : Obuilder_spec.Rom.t list; } [@@deriving sexp_of] - let run t ~switch ~log ~cache ~(rom:Obuilder_spec.Rom.t list) run_input = + let run t ~switch ~log ~cache run_input = + let input = sexp_of_run_input run_input in + let string_input = input |> Sexplib.Sexp.to_string in let id = - sexp_of_run_input run_input + input |> Sexplib.Sexp.to_string_mach |> Sha256.string |> Sha256.to_hex in - let { base; workdir; user; env; cmd; shell; network; mount_secrets } = run_input in - Store.build t.store ?switch ~base ~id ~log (fun ~cancelled ~log result_tmp -> + let { base; workdir; user; env; cmd; shell; network; mount_secrets; rom } = run_input in + Store.build t.store ?switch ~base ~id ~log ~meta:[ ":obuilder-run-input", string_input ] (fun ~cancelled ~log result_tmp -> let to_release = ref [] in Lwt.finalize (fun () -> @@ -200,7 +203,7 @@ module Make (Raw_store : S.STORE) (Sandbox : S.SANDBOX) (Fetch : S.FETCHER) = st } in (* Fmt.pr "COPY: %a@." Sexplib.Sexp.pp_hum (sexp_of_copy_details details); *) let id = Sha256.to_hex (Sha256.string (Sexplib.Sexp.to_string (sexp_of_copy_details details))) in - let res = Store.build t.store ?switch ~base ~id ~log (fun ~cancelled ~log result_tmp -> + let res = Store.build t.store ?switch ~base ~id ~log ~meta:[] (fun ~cancelled ~log result_tmp -> let argv = `Run ["tar"; "-xf"; "-"] in let config = Config.v ~cwd:"/" @@ -272,10 +275,10 @@ module Make (Raw_store : S.STORE) (Sandbox : S.SANDBOX) (Fetch : S.FETCHER) = st let result = let { Context.switch; workdir; user; env; shell; log; src_dir = _; scope = _; secrets } = context in resolve_secrets secrets mount_secrets |> Result.map @@ fun mount_secrets -> - (switch, { base; workdir; user; env; cmd; shell; network; mount_secrets }, log) + (switch, { base; workdir; user; env; cmd; shell; network; mount_secrets; rom }, log) in Lwt.return result >>!= fun (switch, run_input, log) -> - run t ~switch ~log ~cache ~rom run_input >>= fun base -> + run t ~switch ~log ~cache run_input >>= fun base -> match base with | Ok base -> k ~base ~context | Error _ as e -> Lwt.return e @@ -319,7 +322,7 @@ module Make (Raw_store : S.STORE) (Sandbox : S.SANDBOX) (Fetch : S.FETCHER) = st Lwt_result.return (base, ctx) | `Image base -> let id = Sha256.to_hex (Sha256.string base) in - Store.build t.store ~id ~log (fun ~cancelled:_ ~log tmp -> + Store.build t.store ~id ~log ~meta:[ ":obuilder-run-input", Fmt.str "(from %s)" 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"; "-m"; "755"; "--"; rootfs] >>= fun () -> @@ -355,7 +358,7 @@ module Make (Raw_store : S.STORE) (Sandbox : S.SANDBOX) (Fetch : S.FETCHER) = st let shell t ?unix_sock ?stdin id = let stdin = Option.map (fun stdin -> Os.{ raw = stdin; needs_close = false }) stdin in - let rinput = { base = ""; workdir = "/"; user = Obuilder_spec.(`Unix { uid = 1000; gid = 1000 }); env = []; cmd = ""; shell = [ "sh" ]; network = [ "host" ]; mount_secrets = [] } in + let rinput = { base = ""; workdir = "/"; user = Obuilder_spec.(`Unix { uid = 1000; gid = 1000 }); env = []; cmd = ""; shell = [ "sh" ]; network = [ "host" ]; mount_secrets = []; rom = [] } in let established, shell_established = Lwt.wait () in let f = run_shell t ?unix_sock ~shell_established ~switch:None ?stdin ~cache:[] ~rom:[] id rinput in established, f @@ -455,14 +458,16 @@ module Make_Docker (Raw_store : S.STORE) = struct } [@@deriving sexp_of] let run t ~switch ~log ~cache run_input = + let input = sexp_of_run_input run_input in + let string_input = Sexplib.Sexp.to_string input in let id = - sexp_of_run_input run_input + input |> Sexplib.Sexp.to_string_mach |> Sha256.string |> Sha256.to_hex in let { base; workdir; user; env; cmd; shell; network; mount_secrets; rom } = run_input in - Store.build t.store ?switch ~base ~id ~log (fun ~cancelled ~log _ -> + Store.build t.store ?switch ~base ~id ~log ~meta:[ ":obuilder-run-input", string_input ] (fun ~cancelled ~log _ -> let to_release = ref [] in Lwt.finalize (fun () -> @@ -544,8 +549,9 @@ module Make_Docker (Raw_store : S.STORE) = struct } in let dst_dir = match op with `Copy_items (_, dst_dir) when Sys.win32 -> Some dst_dir | _ -> None in (* Fmt.pr "COPY: %a@." Sexplib.Sexp.pp_hum (sexp_of_copy_details details); *) - let id = Sha256.to_hex (Sha256.string (Sexplib.Sexp.to_string (sexp_of_copy_details details))) in - Store.build t.store ?switch ~base ~id ~log (fun ~cancelled ~log _ -> + let copy_details = Sexplib.Sexp.to_string (sexp_of_copy_details details) in + let id = Sha256.to_hex (Sha256.string copy_details) in + Store.build t.store ?switch ~base ~id ~log ~meta:[ ":obuilder-run-input", copy_details ] (fun ~cancelled ~log _ -> match src_dir with | `Context src_dir -> Docker_sandbox.copy_from_context t.sandbox ~cancelled ~log op ~user ~src_dir ?dst_dir id @@ -621,7 +627,7 @@ module Make_Docker (Raw_store : S.STORE) = struct Lwt_result.return (base, env) | `Image base -> let id = Sha256.to_hex (Sha256.string base) in - Store.build t.store ~id ~log (fun ~cancelled:_ ~log:_ _ -> + Store.build t.store ~id ~log ~meta:[":obuilder-run-input", Fmt.str "(from %s)" base ] (fun ~cancelled:_ ~log:_ _ -> Log.info (fun f -> f "Base image not present; importing %S…" base); Docker.Cmd.pull (`Docker_image base) >>= fun () -> Docker.Cmd.tag (`Docker_image base) (Docker.docker_image id) >>= fun () -> diff --git a/lib/db_store.ml b/lib/db_store.ml index 4193513e..ccdd6500 100644 --- a/lib/db_store.ml +++ b/lib/db_store.ml @@ -47,14 +47,14 @@ module Make (Raw : S.STORE) = struct (* Get the result for [id], either by loading it from the disk cache or by doing a new build using [fn]. We only run one instance of this at a time for a single [id]. *) - let rec get_build t ~base ~id ~cancelled ~set_log fn = + let rec get_build t ~base ~id ~cancelled ~set_log ~meta fn = Raw.result t.raw id >>= function | Some res -> Raw.failed t.raw id >>= fun failed_path -> if Sys.file_exists failed_path then begin Logs.info (fun f -> f "Found failed build %s, deleting" res); Raw.delete t.raw id >>= fun () -> - get_build t ~base ~id ~cancelled ~set_log fn + get_build t ~base ~id ~cancelled ~set_log ~meta fn end else begin t.cache_hit <- t.cache_hit + 1; let now = Unix.(gmtime (gettimeofday ())) in @@ -69,7 +69,7 @@ module Make (Raw : S.STORE) = struct end | None -> t.cache_miss <- t.cache_miss + 1; - Raw.build t.raw ?base ~id (fun dir -> + Raw.build t.raw ?base ~id ~meta (fun dir -> Raw.log_file t.raw id >>= fun log_file -> if Sys.file_exists log_file then Unix.unlink log_file; Build_log.create log_file >>= fun log -> @@ -95,7 +95,7 @@ module Make (Raw : S.STORE) = struct let with_temp t id fn = let tmp = "tmp-" ^ id in - Raw.build ~base:id t.raw ~id:tmp fn >>!= fun () -> + Raw.build ~base:id t.raw ~id:tmp ~meta:[] fn >>!= fun () -> Raw.delete t.raw tmp >>= fun () -> Lwt.return @@ Ok () @@ -105,13 +105,13 @@ module Make (Raw : S.STORE) = struct [get_build] should set the log being used as soon as it knows it (this can't happen until we've created the temporary directory in the underlying store). *) - let rec build ?switch t ?base ~id ~log:client_log fn = + let rec build ?switch t ?base ~id ~log:client_log ~meta fn = match Builds.find_opt id t.in_progress with | Some existing when existing.users = 0 -> client_log `Note ("Waiting for previous build to finish cancelling"); assert (Lwt.is_sleeping existing.result); existing.result >>= fun _ -> - build ?switch t ?base ~id ~log:client_log fn + build ?switch t ?base ~id ~log:client_log ~meta fn | Some existing -> (* We're already building this, and the build hasn't been cancelled. *) existing.users <- existing.users + 1; @@ -132,7 +132,7 @@ module Make (Raw : S.STORE) = struct Lwt.async (fun () -> Lwt.try_bind - (fun () -> get_build t ~base ~id ~cancelled ~set_log fn) + (fun () -> get_build t ~base ~id ~cancelled ~set_log ~meta fn) (fun r -> t.in_progress <- Builds.remove id t.in_progress; finish_log ~set_log log >|= fun () -> @@ -150,8 +150,8 @@ module Make (Raw : S.STORE) = struct log_ty client_log ~id ty; Lwt_result.return r - let build ?switch t ?base ~id ~log:client_log fn = - let res = build ?switch t ?base ~id ~log:client_log fn in + let build ?switch t ?base ~id ~log:client_log ~meta fn = + let res = build ?switch t ?base ~id ~log:client_log ~meta fn in (res : (string, [ `Cancelled | `Failed of string * string ]) Lwt_result.t :> (string, [> `Cancelled | `Failed of string * string ]) Lwt_result.t) let result t id = Raw.result t.raw id diff --git a/lib/db_store.mli b/lib/db_store.mli index 6c0a70d4..0ac3895f 100644 --- a/lib/db_store.mli +++ b/lib/db_store.mli @@ -6,6 +6,7 @@ module Make (Raw : S.STORE) : sig t -> ?base:S.id -> id:S.id -> log:S.logger -> + meta:(string * string) list -> (cancelled:unit Lwt.t -> log:Build_log.t -> string -> (unit, [`Cancelled | `Msg of string]) Lwt_result.t) -> (S.id, [> `Cancelled | `Failed of (S.id * string)]) Lwt_result.t (** [build t ~id ~log fn] ensures that [id] is cached, using [fn ~cancelled ~log dir] to build it if not. diff --git a/lib/docker_store.ml b/lib/docker_store.ml index 56443a58..685edc84 100644 --- a/lib/docker_store.ml +++ b/lib/docker_store.ml @@ -106,7 +106,7 @@ let create root = let* () = purge () in Lwt.return t -let build t ?base ~id (fn:(string -> (unit, 'e) Lwt_result.t)) : (unit, 'e) Lwt_result.t = +let build t ?base ~id ~meta:_ (fn:(string -> (unit, 'e) Lwt_result.t)) : (unit, 'e) Lwt_result.t = match base with | None -> Lwt.catch diff --git a/lib/rsync_store.ml b/lib/rsync_store.ml index 8a10913e..771668ab 100644 --- a/lib/rsync_store.ml +++ b/lib/rsync_store.ml @@ -89,7 +89,7 @@ let create ~path ?(mode = Copy) () = Lwt_list.iter_s Rsync.create (Path.dirs path) >|= fun () -> { path; mode; caches = Hashtbl.create 10; next = 0 } -let build t ?base ~id fn = +let build t ?base ~id ~meta:_ fn = Log.debug (fun f -> f "rsync: build %S" id); let result = Path.result t id in let result_tmp = Path.result_tmp t id in diff --git a/lib/s.ml b/lib/s.ml index f8641107..5398a347 100644 --- a/lib/s.ml +++ b/lib/s.ml @@ -22,6 +22,7 @@ module type STORE = sig val build : t -> ?base:id -> id:id -> + meta:(string * string) list -> (string -> (unit, 'e) Lwt_result.t) -> (unit, 'e) Lwt_result.t (** [build t ~id fn] runs [fn tmpdir] to add a new item to the store under @@ -32,7 +33,8 @@ module type STORE = sig The builder will not request concurrent builds for the same [id] (it will handle that itself). It will also not ask for a build that already exists (i.e. for which [result] returns a path). - @param base Initialise [tmpdir] as a clone of [base]. *) + @param base Initialise [tmpdir] as a clone of [base]. + @param meta Metadata that can be stored as a key-value list with the result. *) val delete : t -> id -> unit Lwt.t (** [delete t id] removes [id] from the store, if present. *) diff --git a/lib/xfs_store.ml b/lib/xfs_store.ml index e2b9e819..2cb24eaf 100644 --- a/lib/xfs_store.ml +++ b/lib/xfs_store.ml @@ -56,7 +56,7 @@ let create ~path = Lwt_list.iter_s Xfs.create (Path.dirs path) >|= fun () -> { path; caches = Hashtbl.create 10; next = 0 } -let build t ?base ~id fn = +let build t ?base ~id ~meta:_ fn = Log.debug (fun f -> f "xfs: build %S" id); let result = Path.result t id in let result_tmp = Path.result_tmp t id in diff --git a/lib/zfs_store.ml b/lib/zfs_store.ml index d7ddc2ad..fb7b9a04 100644 --- a/lib/zfs_store.ml +++ b/lib/zfs_store.ml @@ -139,6 +139,12 @@ module Zfs = struct let create_raw t ds = Os.sudo ["zfs"; "create"; "--"; ds ] + let set t ds props = + let set p v = + Os.sudo ["zfs"; "set"; "-u"; Fmt.str "%s=%s" p v; Dataset.full_name t ds ] + in + Lwt_list.iter_s (fun (p, v) -> set p v) props + let destroy t ds mode = let opts = match mode with @@ -248,7 +254,7 @@ let delete t id = On success, we snapshot the clone as clone@snap. On failure, we destroy the clone. This will always succeed because we can't have tagged it or created further clones at this point. *) -let build t ?base ~id fn = +let build t ?base ~id ~meta fn = Log.debug (fun f -> f "zfs: build %S" id); let ds = Dataset.result id in (* We have to create the dataset in its final location because ZFS can't @@ -275,11 +281,13 @@ let build t ?base ~id fn = Zfs.snapshot t ds ~snapshot:default_snapshot >>= fun () -> (* ZFS can't delete the clone while the snapshot still exists. So I guess we'll just keep it around? *) + Zfs.set t ds meta >>= fun () -> Lwt_result.return () | Error _ as e -> Log.debug (fun f -> f "zfs: build %S failed" id); (* Don't delete build results that fail *) (* Zfs.destroy t ds `And_snapshots >>= fun () -> *) + Zfs.set t ds meta >>= fun () -> Lwt.return e ) (fun ex ->