Shared cache

lib/btrfs_store.ml

@@ -173,39 +173,56 @@ let get_cache t name =
     Hashtbl.add t.caches name c;
     c
 
-let cache ~user t name : (string * (unit -> unit Lwt.t)) Lwt.t =
+let cache ?(shared=false) ~user t name : (string * (unit -> unit Lwt.t)) Lwt.t =
   let cache = get_cache t name in
-  Lwt_mutex.with_lock cache.lock @@ fun () ->
-  let tmp = Path.cache_tmp t t.next name in
-  t.next <- t.next + 1;
   let snapshot = Path.cache t name in
-  (* Create cache if it doesn't already exist. *)
-  begin match Os.check_dir snapshot with
-    | `Missing -> Btrfs.subvolume_create snapshot
-    | `Present -> Lwt.return_unit
-  end >>= fun () ->
-  (* Create writeable clone. *)
-  let gen = cache.gen in
-  Btrfs.subvolume_snapshot `RW ~src:snapshot tmp >>= fun () ->
-  begin match user with
-    | `Unix { Obuilder_spec.uid; gid } ->
-      Os.sudo ["chown"; Printf.sprintf "%d:%d" uid gid; tmp]
-    | `Windows _ -> assert false (* btrfs not supported on Windows*)
-  end >>= fun () ->
-  let release () =
+  if shared then
+    (* Shared mode: return the actual cache directory, no copy-on-write *)
     Lwt_mutex.with_lock cache.lock @@ fun () ->
-    begin
-      if cache.gen = gen then (
-        (* The cache hasn't changed since we cloned it. Update it. *)
-        (* todo: check if it has actually changed. *)
-        cache.gen <- cache.gen + 1;
-        Btrfs.subvolume_delete snapshot >>= fun () ->
-        Btrfs.subvolume_snapshot `RO ~src:tmp snapshot
-      ) else Lwt.return_unit
+    (* Create cache if it doesn't already exist. *)
+    begin match Os.check_dir snapshot with
+      | `Missing -> Btrfs.subvolume_create snapshot
+      | `Present -> Lwt.return_unit
     end >>= fun () ->
-    Btrfs.subvolume_delete tmp
-  in
-  Lwt.return (tmp, release)
+    begin match user with
+      | `Unix { Obuilder_spec.uid; gid } ->
+        Os.sudo ["chown"; Printf.sprintf "%d:%d" uid gid; snapshot]
+      | `Windows _ -> assert false (* btrfs not supported on Windows*)
+    end >>= fun () ->
+    let release () = Lwt.return_unit in  (* No-op for shared caches *)
+    Lwt.return (snapshot, release)
+  else
+    (* Non-shared mode: existing copy-on-write behavior *)
+    Lwt_mutex.with_lock cache.lock @@ fun () ->
+    let tmp = Path.cache_tmp t t.next name in
+    t.next <- t.next + 1;
+    (* Create cache if it doesn't already exist. *)
+    begin match Os.check_dir snapshot with
+      | `Missing -> Btrfs.subvolume_create snapshot
+      | `Present -> Lwt.return_unit
+    end >>= fun () ->
+    (* Create writeable clone. *)
+    let gen = cache.gen in
+    Btrfs.subvolume_snapshot `RW ~src:snapshot tmp >>= fun () ->
+    begin match user with
+      | `Unix { Obuilder_spec.uid; gid } ->
+        Os.sudo ["chown"; Printf.sprintf "%d:%d" uid gid; tmp]
+      | `Windows _ -> assert false (* btrfs not supported on Windows*)
+    end >>= fun () ->
+    let release () =
+      Lwt_mutex.with_lock cache.lock @@ fun () ->
+      begin
+        if cache.gen = gen then (
+          (* The cache hasn't changed since we cloned it. Update it. *)
+          (* todo: check if it has actually changed. *)
+          cache.gen <- cache.gen + 1;
+          Btrfs.subvolume_delete snapshot >>= fun () ->
+          Btrfs.subvolume_snapshot `RO ~src:tmp snapshot
+        ) else Lwt.return_unit
+      end >>= fun () ->
+      Btrfs.subvolume_delete tmp
+    in
+    Lwt.return (tmp, release)
 
 let delete_cache t name =
   let cache = get_cache t name in

lib/build.ml

@@ -82,8 +82,10 @@ module Make (Raw_store : S.STORE) (Sandbox : S.SANDBOX) (Fetch : S.FETCHER) = st
         let to_release = ref [] in
         Lwt.finalize
           (fun () ->
-             cache |> Lwt_list.map_s (fun { Obuilder_spec.Cache.id; target; buildkit_options = _ } ->
-                 Store.cache ~user t.store id >|= fun (src, release) ->
+             cache |> Lwt_list.map_s (fun { Obuilder_spec.Cache.id; target; buildkit_options } ->
+                 let shared = List.mem_assoc "sharing" buildkit_options
+                              && List.assoc "sharing" buildkit_options = "shared" in
+                 Store.cache ~shared ~user t.store id >|= fun (src, release) ->
                  to_release := release :: !to_release;
                  { Config.Mount.ty = `Bind; src; dst = target; readonly = false }
                )
@@ -367,8 +369,10 @@ module Make_Docker (Raw_store : S.STORE) = struct
         let to_release = ref [] in
         Lwt.finalize
           (fun () ->
-             cache |> Lwt_list.map_s (fun { Obuilder_spec.Cache.id; target; buildkit_options = _ } ->
-                 Store.cache ~user t.store id >|= fun (src, release) ->
+             cache |> Lwt_list.map_s (fun { Obuilder_spec.Cache.id; target; buildkit_options } ->
+                 let shared = List.mem_assoc "sharing" buildkit_options
+                              && List.assoc "sharing" buildkit_options = "shared" in
+                 Store.cache ~shared ~user t.store id >|= fun (src, release) ->
                  to_release := release :: !to_release;
                  { Config.Mount.ty = `Volume; src; dst = target; readonly = false }
                )

lib/db_store.ml

@@ -134,7 +134,7 @@ module Make (Raw : S.STORE) = struct
   let df t = Raw.df t.raw
   let root t = Raw.root t.raw
   let cache_stats t = t.cache_hit, t.cache_miss
-  let cache ~user t = Raw.cache ~user t.raw
+  let cache ?shared ~user t = Raw.cache ?shared ~user t.raw
 
   let delete ?(log=ignore) t id =
     let rec aux id =

lib/db_store.mli

@@ -29,6 +29,7 @@ module Make (Raw : S.STORE) : sig
   val cache_stats : t -> int * int
 
   val cache :
+    ?shared:bool ->
     user : Obuilder_spec.user ->
     t ->
     string ->

lib/docker_store.ml

@@ -162,41 +162,60 @@ let get_cache t name =
     Hashtbl.add t.caches name c;
     c
 
-let cache ~user t name : (string * (unit -> unit Lwt.t)) Lwt.t =
+let cache ?(shared=false) ~user t name : (string * (unit -> unit Lwt.t)) Lwt.t =
   let cache = get_cache t name in
-  Lwt_mutex.with_lock cache.lock @@ fun () ->
-  let tmp = Cache.cache_tmp t.next name in
-  t.next <- t.next + 1;
   let snapshot = Cache.cache name in
-  (* Create cache if it doesn't already exist. *)
-  let* () =
-    let* exists = Cache.exists snapshot in
-    if not exists then Cache.create snapshot
-    else Lwt.return_unit
-  in
-  (* Create writeable clone. *)
-  let gen = cache.gen in
-  let* () = Cache.snapshot ~src:snapshot tmp in
-  let+ () = match user with
-    | `Unix { Obuilder_spec.uid; gid } ->
-      let* tmp = Docker.Cmd.mount_point tmp in
-      Os.sudo ["chown"; strf "%d:%d" uid gid; tmp]
-    | `Windows _ -> Lwt.return_unit (* FIXME: does Windows need special treatment? *)
-  in
-  let release () =
+  if shared then
+    (* Shared mode: return the actual cache volume, no copy-on-write *)
     Lwt_mutex.with_lock cache.lock @@ fun () ->
+    (* Create cache if it doesn't already exist. *)
     let* () =
-      if cache.gen = gen then (
-        (* The cache hasn't changed since we cloned it. Update it. *)
-        (* todo: check if it has actually changed. *)
-        cache.gen <- cache.gen + 1;
-        let* () = Cache.delete snapshot in
-        Cache.snapshot ~src:tmp snapshot
-      ) else Lwt.return_unit
+      let* exists = Cache.exists snapshot in
+      if not exists then Cache.create snapshot
+      else Lwt.return_unit
     in
-    Cache.delete tmp
-  in
-  Cache.name tmp, release
+    let+ () = match user with
+      | `Unix { Obuilder_spec.uid; gid } ->
+        let* mp = Docker.Cmd.mount_point snapshot in
+        Os.sudo ["chown"; strf "%d:%d" uid gid; mp]
+      | `Windows _ -> Lwt.return_unit (* FIXME: does Windows need special treatment? *)
+    in
+    let release () = Lwt.return_unit in  (* No-op for shared caches *)
+    Cache.name snapshot, release
+  else
+    (* Non-shared mode: existing snapshot behavior *)
+    Lwt_mutex.with_lock cache.lock @@ fun () ->
+    let tmp = Cache.cache_tmp t.next name in
+    t.next <- t.next + 1;
+    (* Create cache if it doesn't already exist. *)
+    let* () =
+      let* exists = Cache.exists snapshot in
+      if not exists then Cache.create snapshot
+      else Lwt.return_unit
+    in
+    (* Create writeable clone. *)
+    let gen = cache.gen in
+    let* () = Cache.snapshot ~src:snapshot tmp in
+    let+ () = match user with
+      | `Unix { Obuilder_spec.uid; gid } ->
+        let* tmp = Docker.Cmd.mount_point tmp in
+        Os.sudo ["chown"; strf "%d:%d" uid gid; tmp]
+      | `Windows _ -> Lwt.return_unit (* FIXME: does Windows need special treatment? *)
+    in
+    let release () =
+      Lwt_mutex.with_lock cache.lock @@ fun () ->
+      let* () =
+        if cache.gen = gen then (
+          (* The cache hasn't changed since we cloned it. Update it. *)
+          (* todo: check if it has actually changed. *)
+          cache.gen <- cache.gen + 1;
+          let* () = Cache.delete snapshot in
+          Cache.snapshot ~src:tmp snapshot
+        ) else Lwt.return_unit
+      in
+      Cache.delete tmp
+    in
+    Cache.name tmp, release
 
 let delete_cache t name =
   let cache = get_cache t name in

lib/overlayfs_store.ml

@@ -243,29 +243,41 @@ let get_cache t name =
       Hashtbl.add t.caches name c;
       c
 
-let cache ~user t name =
+let cache ?(shared=false) ~user t name =
   let cache = get_cache t name in
-  Lwt_mutex.with_lock cache.lock @@ fun () ->
-  let result, work, merged = Path.cache_result t t.next name in
-  t.next <- t.next + 1;
   let master = Path.cache t name in
-  (* Create cache if it doesn't already exist. *)
-  (match Os.check_dir master with
-  | `Missing -> Overlayfs.create ~mode:"1777" ~user [ master ]
-  | `Present -> Lwt.return_unit)
-  >>= fun () ->
-  cache.children <- cache.children + 1;
-  Overlayfs.create ~mode:"1777" ~user [ result; work; merged ] >>= fun () ->
-  let lower = String.split_on_char ':' master |> String.concat "\\:" in
-  Overlayfs.overlay ~lower ~upper:result ~work ~merged >>= fun () ->
-  let release () =
+  if shared then
+    (* Shared mode: return the actual cache directory, no copy-on-write *)
     Lwt_mutex.with_lock cache.lock @@ fun () ->
-       cache.children <- cache.children - 1;
-       Overlayfs.umount ~merged >>= fun () ->
-       Overlayfs.cp ~src:result ~dst:master >>= fun () ->
-       Overlayfs.delete [ result; work; merged ]
-  in
-  Lwt.return (merged, release)
+    (* Create cache if it doesn't already exist. *)
+    (match Os.check_dir master with
+    | `Missing -> Overlayfs.create ~mode:"1777" ~user [ master ]
+    | `Present -> Lwt.return_unit)
+    >>= fun () ->
+    let release () = Lwt.return_unit in  (* No-op for shared caches *)
+    Lwt.return (master, release)
+  else
+    (* Non-shared mode: existing overlay behavior *)
+    Lwt_mutex.with_lock cache.lock @@ fun () ->
+    let result, work, merged = Path.cache_result t t.next name in
+    t.next <- t.next + 1;
+    (* Create cache if it doesn't already exist. *)
+    (match Os.check_dir master with
+    | `Missing -> Overlayfs.create ~mode:"1777" ~user [ master ]
+    | `Present -> Lwt.return_unit)
+    >>= fun () ->
+    cache.children <- cache.children + 1;
+    Overlayfs.create ~mode:"1777" ~user [ result; work; merged ] >>= fun () ->
+    let lower = String.split_on_char ':' master |> String.concat "\\:" in
+    Overlayfs.overlay ~lower ~upper:result ~work ~merged >>= fun () ->
+    let release () =
+      Lwt_mutex.with_lock cache.lock @@ fun () ->
+         cache.children <- cache.children - 1;
+         Overlayfs.umount ~merged >>= fun () ->
+         Overlayfs.cp ~src:result ~dst:master >>= fun () ->
+         Overlayfs.delete [ result; work; merged ]
+    in
+    Lwt.return (merged, release)
 
 let delete_cache t name =
   let () = Printf.printf "0\n" in

lib/qemu_store.ml

@@ -128,31 +128,42 @@ let get_cache t name =
     Hashtbl.add t.caches name c;
     c
 
-let cache ~user:_ t name : (string * (unit -> unit Lwt.t)) Lwt.t =
+let cache ?(shared=false) ~user:_ t name : (string * (unit -> unit Lwt.t)) Lwt.t =
   let cache = get_cache t name in
-  Lwt_mutex.with_lock cache.lock @@ fun () ->
-  let tmp = Path.cache_tmp t t.next name in
-  t.next <- t.next + 1;
   let master = Path.cache t name in
-  (* Create cache if it doesn't already exist. *)
-  (match Os.check_dir master with
-    | `Missing -> Qemu_img.create master
-    | `Present -> Lwt.return ()) >>= fun () ->
-  cache.children <- cache.children + 1;
-  let () = Os.ensure_dir tmp in
-  Os.cp ~src:master tmp >>= fun () ->
-  let release () =
+  if shared then
+    (* Shared mode: return the actual cache directory, no copy-on-write *)
+    Lwt_mutex.with_lock cache.lock @@ fun () ->
+    (* Create cache if it doesn't already exist. *)
+    (match Os.check_dir master with
+      | `Missing -> Qemu_img.create master
+      | `Present -> Lwt.return ()) >>= fun () ->
+    let release () = Lwt.return_unit in  (* No-op for shared caches *)
+    Lwt.return (master, release)
+  else
+    (* Non-shared mode: existing copy behavior *)
     Lwt_mutex.with_lock cache.lock @@ fun () ->
-    cache.children <- cache.children - 1;
-    let cache_stat = Unix.stat (Path.image master) in
-    let tmp_stat = Unix.stat (Path.image tmp) in
-    (if tmp_stat.st_size > cache_stat.st_size then
-      Os.cp ~src:tmp master
-    else
-      Lwt.return ()) >>= fun () ->
-    Os.rm ~directory:tmp
-  in
-  Lwt.return (tmp, release)
+    let tmp = Path.cache_tmp t t.next name in
+    t.next <- t.next + 1;
+    (* Create cache if it doesn't already exist. *)
+    (match Os.check_dir master with
+      | `Missing -> Qemu_img.create master
+      | `Present -> Lwt.return ()) >>= fun () ->
+    cache.children <- cache.children + 1;
+    let () = Os.ensure_dir tmp in
+    Os.cp ~src:master tmp >>= fun () ->
+    let release () =
+      Lwt_mutex.with_lock cache.lock @@ fun () ->
+      cache.children <- cache.children - 1;
+      let cache_stat = Unix.stat (Path.image master) in
+      let tmp_stat = Unix.stat (Path.image tmp) in
+      (if tmp_stat.st_size > cache_stat.st_size then
+        Os.cp ~src:tmp master
+      else
+        Lwt.return ()) >>= fun () ->
+      Os.rm ~directory:tmp
+    in
+    Lwt.return (tmp, release)
 
 let delete_cache t name =
   let cache = get_cache t name in