Merge pull request #1 from quantifyearth/shark+zfs-props

Add ZFS set for extra metadata

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 *)

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 () ->

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

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.

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

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

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. *)

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

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 ->