diff --git a/.run-gha-tests.sh b/.run-gha-tests.sh index 37b362e8..0e1c5ae5 100755 --- a/.run-gha-tests.sh +++ b/.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 diff --git a/lib/rsync_store.ml b/lib/rsync_store.ml index 4255c6d0..d0907c4c 100644 --- a/lib/rsync_store.ml +++ b/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 diff --git a/lib/rsync_store.mli b/lib/rsync_store.mli index c44f24c1..e8dfda8f 100644 --- a/lib/rsync_store.mli +++ b/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. *) diff --git a/lib/store_spec.ml b/lib/store_spec.ml index 2ef23e57..8947469c 100644 --- a/lib/store_spec.ml +++ b/lib/store_spec.ml @@ -24,7 +24,7 @@ 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) @@ -32,5 +32,31 @@ let to_store = function 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) diff --git a/main.ml b/main.ml index 25c8c681..dd1621d5 100644 --- a/main.ml +++ b/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 @@ diff --git a/stress/stress.ml b/stress/stress.ml index ca797173..9168f5cf 100644 --- a/stress/stress.ml +++ b/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 () =