XFS aka reflink store

.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
 

.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:

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 =

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

lib/xfs_store.mli

@@ -0,0 +1,7 @@
+(** Store build results using rsync. *)
+
+include S.STORE
+
+val create : path:string -> t Lwt.t
+(** [create ~path] creates a new xfs store where everything will
+    be stored under [path]. *)