diff --git a/.github/workflows/main.sh b/.github/workflows/main.sh index 3326841b..954a35ac 100755 --- a/.github/workflows/main.sh +++ b/.github/workflows/main.sh @@ -16,6 +16,32 @@ sudo chmod a+x /usr/local/bin/uname opam exec -- make case "$1" in + xfs) + sudo chmod a+x /usr/local/bin/runc + + dd if=/dev/zero of=/tmp/xfs.img bs=100M count=100 + XFS_LOOP=$(sudo losetup -f) + sudo losetup -P "$XFS_LOOP" /tmp/xfs.img + sudo mkfs.xfs -f "$XFS_LOOP" + sudo mkdir /xfs + sudo mount -t xfs "$XFS_LOOP" /xfs + sudo chown "$(whoami)" /xfs + + opam exec -- dune exec -- obuilder healthcheck --store=xfs:/xfs + opam exec -- dune exec -- ./stress/stress.exe --store=xfs:/xfs + + # Populate the caches from our own GitHub Actions cache + mkdir -p /xfs/cache/c-opam-archives + cp -r ~/.opam/download-cache/* /xfs/cache/c-opam-archives/ + sudo chown -R 1000:1000 /xfs/cache/c-opam-archives + + opam exec -- dune exec -- obuilder build -f example.spec . --store=xfs:/xfs --color=always + + sudo umount /xfs + sudo losetup -d "$XFS_LOOP" + sudo rm -f /tmp/xfs.img + ;; + btrfs) sudo chmod a+x /usr/local/bin/runc diff --git a/.github/workflows/main.yml b/.github/workflows/main.yml index d8408baa..d0e0e537 100644 --- a/.github/workflows/main.yml +++ b/.github/workflows/main.yml @@ -30,7 +30,7 @@ jobs: - uses: awalsh128/cache-apt-pkgs-action@latest with: - packages: btrfs-progs zfs-dkms zfsutils-linux + packages: btrfs-progs zfs-dkms zfsutils-linux xfsprogs version: 2 - name: Checkout code @@ -57,6 +57,7 @@ jobs: - run: $GITHUB_WORKSPACE/.github/workflows/main.sh btrfs - run: $GITHUB_WORKSPACE/.github/workflows/main.sh zfs + - run: $GITHUB_WORKSPACE/.github/workflows/main.sh xfs build_rsync: strategy: diff --git a/lib/obuilder.ml b/lib/obuilder.ml index b3e19893..f036dd21 100644 --- a/lib/obuilder.ml +++ b/lib/obuilder.ml @@ -12,6 +12,7 @@ module Docker = Docker module Btrfs_store = Btrfs_store module Zfs_store = Zfs_store module Rsync_store = Rsync_store +module Xfs_store = Xfs_store module Store_spec = Store_spec module Docker_store = Docker_store diff --git a/lib/store_spec.ml b/lib/store_spec.ml index 7d251f7d..adb8366f 100644 --- a/lib/store_spec.ml +++ b/lib/store_spec.ml @@ -6,6 +6,7 @@ type t = [ | `Btrfs of string (* Path *) | `Zfs of string (* Path with pool at end *) | `Rsync of (string * Rsync_store.mode) (* Path for the root of the store *) + | `Xfs of string (* Path *) | `Docker of string (* Path *) ] @@ -16,13 +17,15 @@ let of_string s = | Some ("zfs", pool) -> Ok (`Zfs pool) | Some ("btrfs", path) when is_absolute path -> Ok (`Btrfs path) | Some ("rsync", path) when is_absolute path -> Ok (`Rsync path) + | Some ("xfs", path) when is_absolute path -> Ok (`Xfs path) | Some ("docker", path) -> Ok (`Docker path) - | _ -> Error (`Msg "Store must start with zfs: or btrfs:/ or rsync:/") + | _ -> Error (`Msg "Store must start with zfs:, btrfs:/, rsync:/ or xfs:/") let pp f = function | `Zfs path -> Fmt.pf f "zfs:%s" path | `Btrfs path -> Fmt.pf f "btrfs:%s" path | `Rsync path -> Fmt.pf f "rsync:%s" path + | `Xfs path -> Fmt.pf f "xfs:%s" path | `Docker path -> Fmt.pf f "docker:%s" path type store = Store : (module S.STORE with type t = 'a) * 'a -> store @@ -37,6 +40,9 @@ let to_store = function | `Rsync (path, rsync_mode) -> `Native, Rsync_store.create ~path ~mode:rsync_mode () >|= fun store -> Store ((module Rsync_store), store) + | `Xfs path -> + `Native, Xfs_store.create ~path >|= fun store -> + Store ((module Xfs_store), store) | `Docker path -> `Docker, Docker_store.create path >|= fun store -> Store ((module Docker_store), store) @@ -48,7 +54,7 @@ let store_t = Arg.conv (of_string, pp) let store ?docs names = Arg.opt Arg.(some store_t) None @@ Arg.info - ~doc:"$(docv) must be one of $(b,btrfs:/path), $(b,rsync:/path), $(b,zfs:pool) or $(b,docker:path) for the OBuilder cache." + ~doc:"$(docv) must be one of $(b,btrfs:/path), $(b,rsync:/path), $(b,xfs:/path), $(b,zfs:pool) or $(b,docker:path) for the OBuilder cache." ~docv:"STORE" ?docs names @@ -80,8 +86,9 @@ let of_t store rsync_mode = | Some (`Rsync _path), None -> failwith "Store rsync:/ must supply an rsync-mode" | Some (`Btrfs path), None -> (`Btrfs path) | Some (`Zfs path), None -> (`Zfs path) + | Some (`Xfs path), None -> (`Xfs path) | Some (`Docker path), None -> (`Docker path) - | _, _ -> failwith "Store type required must be one of btrfs:/path, rsync:/path, zfs:pool or docker:path for the OBuilder cache." + | _, _ -> failwith "Store type required must be one of btrfs:/path, rsync:/path, xfs:/path, zfs:pool or docker:path for the OBuilder cache." (** Parse cli arguments for t *) let v = diff --git a/lib/xfs_store.ml b/lib/xfs_store.ml new file mode 100644 index 00000000..7ae68ab3 --- /dev/null +++ b/lib/xfs_store.ml @@ -0,0 +1,155 @@ +(* This store will work with any file system which supports reflinks. *) +open Lwt.Infix + +type cache = { + lock : Lwt_mutex.t; + mutable gen : int; +} + +type t = { + path : string; + caches : (string, cache) Hashtbl.t; + mutable next : int; +} + +let ( / ) = Filename.concat + +module Xfs = struct + let create dir = Lwt.return @@ Os.ensure_dir dir + + let delete dir = + Os.sudo [ "rm"; "-r"; dir ] + + let cp ~src ~dst = + Os.sudo [ "cp"; "-pRduT"; "--reflink=always"; src; dst ] + + let rename ~src ~dst = + Os.sudo [ "mv"; src; dst ] +end + +module Path = struct + let state_dirname = "state" + let cache_dirname = "cache" + let cache_tmp_dirname = "cache-tmp" + + let result_dirname = "result" + let result_tmp_dirname = "result-tmp" + + let dirs root = + List.map ((/) root) + [ state_dirname; cache_dirname; cache_tmp_dirname; result_dirname; result_tmp_dirname ] + + let result t id = t.path / result_dirname / id + let cache t id = t.path / cache_dirname / id + + let cache_tmp t n id = t.path / cache_tmp_dirname / Printf.sprintf "%i-%s" n id + + let result_tmp t id = t.path / result_tmp_dirname / id +end + +let root t = t.path + +let df t = Lwt.return (Os.free_space_percent t.path) + +let create ~path = + Xfs.create path >>= fun () -> + Lwt_list.iter_s Xfs.create (Path.dirs path) >|= fun () -> + { path; caches = Hashtbl.create 10; next = 0 } + +let build t ?base ~id 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 + let base = Option.map (Path.result t) base in + begin match base with + | None -> Xfs.create result_tmp + | Some src -> Xfs.cp ~src ~dst:result_tmp + end + >>= fun () -> + Lwt.try_bind + (fun () -> fn result_tmp) + (fun r -> + begin match r with + | Ok () -> Xfs.rename ~src:result_tmp ~dst:result + | Error _ -> Xfs.delete result_tmp + end >>= fun () -> + Lwt.return r + ) + (fun ex -> + Log.warn (fun f -> f "Uncaught exception from %S build function: %a" id Fmt.exn ex); + Xfs.delete result_tmp >>= fun () -> + Lwt.fail ex + ) + +let delete t id = + let path = Path.result t id in + match Os.check_dir path with + | `Present -> Xfs.delete path + | `Missing -> Lwt.return_unit + +let result t id = + let dir = Path.result t id in + match Os.check_dir dir with + | `Present -> Lwt.return_some dir + | `Missing -> Lwt.return_none + +let log_file t id = + result t id >|= function + | Some dir -> dir / "log" + | None -> (Path.result_tmp t id) / "log" + +let state_dir t = t.path / Path.state_dirname + +let get_cache t name = + match Hashtbl.find_opt t.caches name with + | Some c -> c + | None -> + let c = { lock = Lwt_mutex.create (); gen = 0 } in + Hashtbl.add t.caches name c; + c + +let cache ~user t name = + 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 -> Xfs.create snapshot >>= fun () -> + let { Obuilder_spec.uid; gid } = match user with + | `Unix user -> user + | `Windows _ -> assert false (* xfs not supported on Windows *) + in + Os.sudo [ "chown"; Printf.sprintf "%d:%d" uid gid; snapshot ] + | `Present -> Lwt.return_unit + end >>= fun () -> + (* Create writeable clone. *) + let gen = cache.gen in + Xfs.cp ~src:snapshot ~dst:tmp >>= 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; + Xfs.delete snapshot >>= fun () -> + Xfs.rename ~src:tmp ~dst:snapshot + ) else + Xfs.delete tmp + end + in + Lwt.return (tmp, release) + +let delete_cache t name = + let cache = get_cache t name in + Lwt_mutex.with_lock cache.lock @@ fun () -> + cache.gen <- cache.gen + 1; (* Ensures in-progress writes will be discarded *) + let snapshot = Path.cache t name in + if Sys.file_exists snapshot then ( + Xfs.delete snapshot >>= fun () -> + Lwt_result.return () + ) else Lwt_result.return () + +let complete_deletes _t = Lwt.return_unit diff --git a/lib/xfs_store.mli b/lib/xfs_store.mli new file mode 100644 index 00000000..a0870617 --- /dev/null +++ b/lib/xfs_store.mli @@ -0,0 +1,11 @@ +(** Store builds results using {b XFS} with the reflink feature. + + XFS is intended to behave consistently as it scales to large storage and many files, modern-day XFS was originally from SGI Irix. This store uses the {b reflink} feature in XFS to share blocks between files, to support fast snapshots of directory trees and deduplicate file data for more efficient use of storage hardware. + + For more details on the XFS implementation see {{: https://blogs.oracle.com/linux/post/xfs-data-block-sharing-reflink} XFS - Data Block Sharing (Reflink)} and {{: https://blogs.oracle.com/linux/post/upcoming-xfs-work-in-linux-v48-v49-and-v410-by-darrick-wong} Upcoming XFS Work in Linux v4.8 v4.9 and v4.10+}. *) + +include S.STORE + +val create : path:string -> t Lwt.t +(** [create ~path] creates a new XFS store where everything will + be stored under [path]. *)