Add rsync option for copy or hardlink

.run-gha-tests.sh

@@ -35,9 +35,9 @@ opam exec -- make
 opam exec -- dune exec -- obuilder healthcheck --store=btrfs:/btrfs
 opam exec -- dune exec -- obuilder healthcheck --store=rsync:/rsync
 opam exec -- dune exec -- obuilder healthcheck --store=zfs:zfs
-opam exec -- dune exec -- ./stress/stress.exe btrfs:/btrfs
-opam exec -- dune exec -- ./stress/stress.exe rsync:/rsync
-opam exec -- dune exec -- ./stress/stress.exe zfs:zfs
+opam exec -- dune exec -- ./stress/stress.exe --store=btrfs:/btrfs
+opam exec -- dune exec -- ./stress/stress.exe --store=rsync:/rsync
+opam exec -- dune exec -- ./stress/stress.exe --store=zfs:zfs
 
 # Populate the caches from our own GitHub Actions cache
 btrfs subvolume create /btrfs/cache/c-opam-archives

lib/rsync_store.ml

@@ -10,8 +10,14 @@ type cache = {
   mutable gen : int;
 }
 
+type mode =
+  | Copy
+  | Hardlink
+  | Hardlink_unsafe
+
 type t = {
     path : string;
+    mode : mode;
     caches : (string, cache) Hashtbl.t;
     mutable next : int;
 }
@@ -30,11 +36,15 @@ module Rsync = struct
     let cmd = [ "mv"; src; dst ] in
     Os.sudo cmd
 
-  let rename_with_sharing ~base ~src ~dst = match base with
-    | None -> rename ~src ~dst
-    | Some base ->
+  let rename_with_sharing ~mode ~base ~src ~dst = match mode, base with
+    | Copy, _ | _, None -> rename ~src ~dst
+    | _, Some base ->
         (* Attempt to hard-link existing files shared with [base] *)
-        let cmd = rsync @ [ "--checksum"; "--link-dest=" ^ base; src ^ "/"; dst ] in
+        let safe = match mode with
+          | Hardlink -> ["--checksum"]
+          | _ -> []
+        in
+        let cmd = rsync @ safe @ ["--link-dest=" ^ base; src ^ "/"; dst ] in
         Os.ensure_dir dst;
         Os.sudo cmd >>= fun () ->
         delete src
@@ -69,10 +79,10 @@ module Path = struct
   let result_tmp t id = t.path / result_tmp_dirname / id
 end
 
-let create ~path =
+let create ~path ?(mode = Copy) () =
   Rsync.create path >>= fun () ->
   Lwt_list.iter_s Rsync.create (Path.dirs path) >|= fun () ->
-  { path; caches = Hashtbl.create 10; next = 0 }
+  { path; mode; caches = Hashtbl.create 10; next = 0 }
 
 let build t ?base ~id fn =
   Log.debug (fun f -> f "rsync: build %S" id);
@@ -88,7 +98,7 @@ let build t ?base ~id fn =
       (fun () -> fn result_tmp)
       (fun r ->
       begin match r with
-          | Ok () -> Rsync.rename_with_sharing ~base ~src:result_tmp ~dst:result
+          | Ok () -> Rsync.rename_with_sharing ~mode:t.mode ~base ~src:result_tmp ~dst:result
           | Error _ -> Lwt.return_unit
       end >>= fun () ->
       Lwt.return r

lib/rsync_store.mli

@@ -2,6 +2,15 @@
 
 include S.STORE
 
-val create : path:string -> t Lwt.t
-(** [create ~path] creates a new rsync store where everything will
-    be stored under [path]. *)
+type mode =
+  | Copy (** Fast but uses more disk space. *)
+  | Hardlink (** Slow but consumes less disk space. *)
+  | Hardlink_unsafe (** Reasonnably fast and uses less disk space, but no
+                        checksum verification. Only for testing during
+                        development, do not use in production. *)
+
+val create : path:string -> ?mode:mode -> unit -> t Lwt.t
+(** [create ~path ?mode ()] creates a new rsync store where everything will
+    be stored under [path]. The [mode] defaults to [Copy] and defines how
+    the caches are reused: [Copy] copies all the files, while [Hardlink] tries
+    to save disk space by sharing identical files. *)

lib/store_spec.ml

@@ -24,13 +24,39 @@ let pp f = function
 
 type store = Store : (module S.STORE with type t = 'a) * 'a -> store
 
-let to_store = function
+let to_store mode = function
   | `Btrfs path ->
     Btrfs_store.create path >|= fun store ->
     Store ((module Btrfs_store), store)
   | `Zfs pool ->
     Zfs_store.create ~pool >|= fun store ->
     Store ((module Zfs_store), store)
   | `Rsync path ->
-    Rsync_store.create ~path >|= fun store ->
+    Rsync_store.create ~path ~mode () >|= fun store ->
     Store ((module Rsync_store), store)
+
+let cmdliner =
+  let open Cmdliner in
+  let store_t = Arg.conv (of_string, pp) in
+  let store =
+    Arg.required @@
+    Arg.opt Arg.(some store_t) None @@
+    Arg.info
+      ~doc:"$(b,btrfs:/path) or $(b,rsync:/path) or $(b,zfs:pool) for build cache."
+      ~docv:"STORE"
+      ["store"]
+  in
+  let rsync_mode =
+    let options =
+      [("copy", Rsync_store.Copy);
+       ("hardlink", Rsync_store.Hardlink);
+       ("hardlink_unsafe", Rsync_store.Hardlink_unsafe)]
+    in
+    Arg.value @@
+    Arg.opt (Arg.enum options) Rsync_store.Copy @@
+    Arg.info
+      ~doc:"$(b,copy) or $(b,hardlink), to optimize for speed or low disk usage."
+      ~docv:"RSYNC_MODE"
+      ["rsync-mode"]
+  in
+  Term.(const to_store $ rsync_mode $ store)

main.ml

@@ -4,6 +4,7 @@ let ( / ) = Filename.concat
 
 module Sandbox = Obuilder.Runc_sandbox
 module Fetcher = Obuilder.Docker
+module Store_spec = Obuilder.Store_spec
 
 type builder = Builder : (module Obuilder.BUILDER with type t = 'a) * 'a -> builder
 
@@ -14,7 +15,7 @@ let log tag msg =
   | `Output -> output_string stdout msg; flush stdout
 
 let create_builder spec conf =
-  Obuilder.Store_spec.to_store spec >>= fun (Store ((module Store), store)) ->
+  spec >>= fun (Store_spec.Store ((module Store), store)) ->
   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
@@ -101,16 +102,7 @@ let src_dir =
     ~docv:"DIR"
     []
 
-let store_t =
-  Arg.conv Obuilder.Store_spec.(of_string, pp)
-
-let store =
-  Arg.required @@
-  Arg.opt Arg.(some store_t) None @@
-  Arg.info
-    ~doc:"$(b,btrfs:/path) or $(b,rsync:/path) or $(b,zfs:pool) for build cache."
-    ~docv:"STORE"
-    ["store"]
+let store = Store_spec.cmdliner
 
 let id =
   Arg.required @@

stress/stress.ml

@@ -211,7 +211,7 @@ end
 
 let stress spec conf =
   Lwt_main.run begin
-    Store_spec.to_store spec >>= fun (Store ((module Store), store)) ->
+    spec >>= fun (Store_spec.Store ((module Store), store)) ->
     let module T = Test(Store) in
     T.test_store store >>= fun () ->
     T.test_cache store >>= fun () ->
@@ -221,22 +221,11 @@ let stress spec conf =
 
 open Cmdliner
 
-let store_t =
-  Arg.conv Obuilder.Store_spec.(of_string, pp)
-
-let store =
-  Arg.required @@
-  Arg.pos 0 Arg.(some store_t) None @@
-  Arg.info
-    ~doc:"zfs:pool or btrfs:/path for build cache"
-    ~docv:"STORE"
-    []
-
 let cmd =
   let doc = "Run stress tests." in
   let info = Cmd.info ~doc "stress" in
   Cmd.v info
-    Term.(const stress $ store $ Sandbox.cmdliner)
+    Term.(const stress $ Store_spec.cmdliner $ Sandbox.cmdliner)
 
 
 let () =