Skip to content

Commit

Permalink
Merge pull request #170 from mtelvers/xfs
Browse files Browse the repository at this point in the history
XFS aka reflink store
  • Loading branch information
tmcgilchrist authored Sep 6, 2023
2 parents df2d3ad + 07e16d4 commit d68e0f3
Show file tree
Hide file tree
Showing 6 changed files with 205 additions and 4 deletions.
26 changes: 26 additions & 0 deletions .github/workflows/main.sh
Original file line number Diff line number Diff line change
Expand Up @@ -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

Expand Down
3 changes: 2 additions & 1 deletion .github/workflows/main.yml
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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:
Expand Down
1 change: 1 addition & 0 deletions lib/obuilder.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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

Expand Down
13 changes: 10 additions & 3 deletions lib/store_spec.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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 *)
]

Expand All @@ -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
Expand All @@ -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)
Expand All @@ -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
Expand Down Expand Up @@ -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 =
Expand Down
155 changes: 155 additions & 0 deletions lib/xfs_store.ml
Original file line number Diff line number Diff line change
@@ -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
11 changes: 11 additions & 0 deletions lib/xfs_store.mli
Original file line number Diff line number Diff line change
@@ -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]. *)

0 comments on commit d68e0f3

Please sign in to comment.