Overlayfs backend

.github/workflows/main.sh

@@ -16,6 +16,26 @@ sudo chmod a+x /usr/local/bin/uname
 opam exec -- make
 
 case "$1" in
+    overlayfs)
+        sudo chmod a+x /usr/local/bin/runc
+
+        sudo mkdir /overlayfs
+        sudo mount -t tmpfs -o size=10G tmpfs /overlayfs
+        sudo chown "$(whoami)" /overlayfs
+
+        opam exec -- dune exec -- obuilder healthcheck --store=overlayfs:/overlayfs
+        opam exec -- dune exec -- ./stress/stress.exe --store=overlayfs:/overlayfs
+
+        # Populate the caches from our own GitHub Actions cache
+	mkdir -p /overlayfs/cache/c-opam-archives
+        cp -r ~/.opam/download-cache/* /overlayfs/cache/c-opam-archives/
+        sudo chown -R 1000:1000 /overlayfs/cache/c-opam-archives
+
+        opam exec -- dune exec -- obuilder build -f example.spec . --store=overlayfs:/overlayfs --color=always
+
+        sudo umount /overlayfs
+        ;;
+
     xfs)
         sudo chmod a+x /usr/local/bin/runc
 
@@ -165,6 +185,6 @@ case "$1" in
        ;;
 
     *)
-        printf "Usage: .run-gha-tests.sh [btrfs|rsync_hardlink|rsync_copy|zfs]" >&2
+        printf "Usage: .run-gha-tests.sh [btrfs|rsync_hardlink|rsync_copy|zfs|overlayfs]" >&2
         exit 1
 esac

.github/workflows/main.yml

@@ -23,14 +23,9 @@ jobs:
     runs-on: ${{ matrix.os }}
 
     steps:
-      # The ppa is needed because of https://www.mail-archive.com/[email protected]/msg5972997.html
-      - run: |
-          sudo add-apt-repository ppa:jonathonf/zfs && \
-          sudo apt-get --allow-releaseinfo-change update
-
       - uses: awalsh128/cache-apt-pkgs-action@latest
         with:
-          packages: btrfs-progs zfs-dkms zfsutils-linux xfsprogs
+          packages: btrfs-progs zfsutils-linux xfsprogs
           version: 2
 
       - name: Checkout code
@@ -55,6 +50,7 @@ jobs:
         run: |
           sudo wget https://github.com/opencontainers/runc/releases/download/$RUNC_VERSION/runc.amd64 -O /usr/local/bin/runc
 
+      - run: $GITHUB_WORKSPACE/.github/workflows/main.sh overlayfs
       - run: $GITHUB_WORKSPACE/.github/workflows/main.sh btrfs
       - run: $GITHUB_WORKSPACE/.github/workflows/main.sh zfs
       - run: $GITHUB_WORKSPACE/.github/workflows/main.sh xfs

lib/os.ml

@@ -218,6 +218,11 @@ let ensure_dir ?(mode=0o777) path =
   | `Present -> ()
   | `Missing -> Unix.mkdir path mode
 
+let read_link x =
+  match Unix.readlink x with
+  | s -> Some s
+  | exception Unix.Unix_error(Unix.ENOENT, _, _) -> None
+
 let rm ~directory =
   let pp _ ppf = Fmt.pf ppf "[ RM ]" in
   sudo_result ~pp:(pp "RM") ["rm"; "-r"; directory ] >>= fun t ->
@@ -287,3 +292,12 @@ let free_space_percent root_dir =
   let used = Int64.sub vfs.f_blocks vfs.f_bfree in
   100. -. 100. *. (Int64.to_float used) /. Int64.(to_float (add used vfs.f_bavail))
 
+let read_lines name process =
+  let ic = open_in name in
+  let try_read () =
+    try Some (input_line ic) with End_of_file -> None in
+  let rec loop acc = match try_read () with
+    | Some s -> loop ((process s) :: acc)
+    | None -> close_in ic; acc in
+  loop []
+

lib/overlayfs_store.ml

@@ -0,0 +1,283 @@
+(*
+  Overlayfs creates a writable layer on top of an existing file system. e.g.
+
+  mkdir {lower,upper,work,merge}
+  mount -t overlay overlay -olowerdir=./lower,upperdir=./upper,workdir=./work ./merge
+
+  ./lower would be our base image, ./upper is overlayed on top of ./lower resulting in ./merge.
+  ./merge is r/w, with the writes held in ./upper.
+  ./work is a temporary working directory.
+
+  Overlayfs supports lowerdir being another overlayfs.  Sadly, the kernel source limits the depth of the stack to 2.
+
+  #define FILESYSTEM_MAX_STACK_DEPTH 2
+
+  However, lowerdir maybe a colon seperated list of lower layers which are stacked left to right.
+
+  mount -t overlay overlay -olowerdir=./l1:./l2:./l3,upperdir=./upper,workdir=./work ./merge
+
+  l1 being the lowerest layer with l2 being the middle layer with l3 on top.
+
+  The layer stacking order is maintained using a symlink "parent" created in each lowerdir pointing to the parent.
+
+  Overlayfs can be used on top of many other filesystem including ext4, xfs and tmpfs.  128GB tmpfs could be created as follows:
+
+  mount -t tmpfs -o size=128g tmpfs /var/cache/obuilder
+  ocluster-worker ... --obuilder-store=overlayfs:/var/cache/obuilder
+ *)
+
+open Lwt.Infix
+
+type cache = {
+  lock : Lwt_mutex.t;
+  mutable children : int;
+}
+
+type t = {
+  path : string;
+  caches : (string, cache) Hashtbl.t;
+  mutable next : int;
+}
+
+let ( / ) = Filename.concat
+
+module Overlayfs = struct
+  let create ?mode ?user dirs =
+    match mode with
+    | None -> Os.exec ([ "mkdir"; "-p" ] @ dirs)
+    | Some mode -> Os.exec ([ "mkdir"; "-p"; "-m"; mode ] @ dirs) >>= fun () ->
+      match user with
+      | None -> Lwt.return_unit
+      | Some `Unix user ->
+        let { Obuilder_spec.uid; gid } = user in
+        Os.sudo ([ "chown"; Printf.sprintf "%d:%d" uid gid; ] @ dirs)
+      | Some `Windows _ -> assert false (* overlayfs not supported on Windows *)
+
+  let delete dirs =
+    match dirs with
+    | [] -> Lwt.return_unit
+    | d -> Os.sudo ([ "rm"; "-rf" ] @ d)
+
+  let rename ~src ~dst =
+    Os.sudo [ "mv"; src; dst ]
+
+  let overlay ~lower ~upper ~work ~merged =
+    Os.sudo [ "mount"; "-t"; "overlay"; "overlay"; "-olowerdir=" ^ lower ^ ",upperdir=" ^ upper ^ ",workdir=" ^ work; merged; ]
+
+  let cp ~src ~dst = Os.sudo [ "cp"; "-plRduTf"; src; dst ]
+  (*
+   * -p     same as --preserve=mode,ownership,timestamps
+   * -l     hard link files instead of copying
+   * -R     copy directories recursively
+   * -d     same as --no-dereference --preserve=links
+   * -u     copy only when the SOURCE file is newer than the destination file or when the destination file is missing
+   * -T     treat DEST as a normal file
+   *)
+
+  let umount ~merged = Os.sudo [ "umount"; merged ]
+end
+
+module Path = struct
+  let state_dirname = "state"
+  let cache_dirname = "cache"
+  let cache_result_dirname = "cache-result"
+  let cache_work_dirname = "cache-work"
+  let cache_merged_dirname = "cache-merged"
+  let result_dirname = "result"
+  let in_progress_dirname = "in-progress"
+  let merged_dirname = "merged"
+  let work_dirname = "work"
+
+  let dirs root =
+    List.map (( / ) root)
+      [ state_dirname;
+        cache_dirname;
+        cache_result_dirname;
+        cache_work_dirname;
+        cache_merged_dirname;
+        result_dirname;
+        in_progress_dirname;
+        merged_dirname;
+        work_dirname; ]
+
+  let result t id = t.path / result_dirname / id
+  let in_progress t id = t.path / in_progress_dirname / id
+  let merged t id = t.path / merged_dirname / id
+  let work t id = t.path / work_dirname / id
+
+  let cache t name = t.path / cache_dirname / name
+  let cache_result t n name =
+    ( t.path / cache_result_dirname / name ^ "-" ^ Int.to_string n,
+      t.path / cache_work_dirname / name ^ "-" ^ Int.to_string n,
+      t.path / cache_merged_dirname / name ^ "-" ^ Int.to_string n)
+end
+
+let root t = t.path
+
+let df t =
+  Lwt_process.pread ("", [| "df"; "-k"; "--output=used,size"; t.path |])
+  >>= fun output ->
+  let used, blocks =
+    String.split_on_char '\n' output
+    |> List.filter_map (fun s ->
+       match Scanf.sscanf s " %Ld %Ld " (fun used blocks -> (used, blocks)) with
+       | used, blocks -> Some (Int64.to_float used, Int64.to_float blocks)
+       | (exception Scanf.Scan_failure _) | (exception End_of_file) -> None)
+    |> List.fold_left (fun (used, blocks) (u, b) -> (used +. u, blocks +. b)) (0., 0.)
+  in
+  Lwt.return (100. -. (100. *. (used /. blocks)))
+
+let create ~path =
+  Overlayfs.create (Path.dirs path) >>= fun () ->
+  let parse_mtab s =
+    match Scanf.sscanf s "%s %s %s %s %s %s" (fun _ mp _ _ _ _ -> mp) with
+    | x -> Some x
+    | (exception Scanf.Scan_failure _) | (exception End_of_file) -> None
+  in
+  let mounts =
+    Os.read_lines "/etc/mtab" parse_mtab
+    |> List.filter_map (function
+      | Some x ->
+         if String.length x > String.length path
+             && String.starts_with ~prefix:path x
+         then Some x
+         else None
+      | None -> None)
+  in
+  Lwt_list.iter_s
+    (fun merged ->
+      Log.warn (fun f -> f "Unmounting left-over folder %S" merged);
+      Overlayfs.umount ~merged)
+    mounts
+  >>= fun () ->
+  Lwt_list.iter_s
+    (fun path ->
+      Sys.readdir path |> Array.to_list
+      |> List.map (Filename.concat path)
+      |> Overlayfs.delete)
+    [ path / Path.in_progress_dirname;
+      path / Path.merged_dirname;
+      path / Path.cache_result_dirname;
+      path / Path.cache_work_dirname;
+      path / Path.cache_merged_dirname;
+      path / Path.work_dirname; ]
+  >|= fun () -> { path; caches = Hashtbl.create 10; next = 0 }
+
+let build t ?base ~id fn =
+  Log.debug (fun f -> f "overlayfs: build %S" id);
+  let result = Path.result t id in
+  let in_progress = Path.in_progress t id in
+  let merged = Path.merged t id in
+  let work = Path.work t id in
+  Overlayfs.create [ in_progress; work; merged ] >>= fun () ->
+  let _ = Option.map (Path.in_progress t) base in
+  (match base with
+  | None ->
+      Lwt.return_unit
+  | Some src ->
+      let src = Path.result t src in
+      Unix.symlink src (in_progress / "parent");
+      Unix.symlink (src / "env") (in_progress / "env");
+      let rec ancestors src = src :: (match Os.read_link (src / "parent") with
+          | Some p -> ancestors p
+          | None -> [])
+      in
+      let lower = ancestors src |> String.concat ":" in
+      Overlayfs.overlay ~lower ~upper:in_progress ~work ~merged)
+  >>= fun () ->
+  Lwt.try_bind
+    (fun () -> match base with
+      | None -> fn in_progress
+      | Some _ -> fn merged)
+    (fun r ->
+      (match base with
+      | None -> Lwt.return_unit
+      | Some _ -> Overlayfs.umount ~merged)
+      >>= fun () ->
+      (match r with
+      | Ok () ->
+        Overlayfs.rename ~src:in_progress ~dst:result >>= fun () ->
+        Overlayfs.delete [ merged; work ]
+      | Error _ -> Overlayfs.delete [ merged; work; in_progress ])
+      >>= fun () -> Lwt.return r)
+    (fun ex ->
+      Log.warn (fun f -> f "Uncaught exception from %S build function: %a" id Fmt.exn ex);
+      Overlayfs.delete [ merged; work; in_progress ] >>= fun () -> Lwt.fail ex)
+
+let delete t id =
+  let path = Path.result t id in
+  let results = t.path / Path.result_dirname in
+  let rec decendants parent =
+    Sys.readdir results
+      |> Array.to_list
+      |> List.map (Filename.concat results)
+      |> List.filter (fun dir ->
+        match Os.read_link (dir / "parent") with
+        | Some p -> p = parent
+        | None -> false)
+      |> List.map decendants
+      |> List.flatten
+      |> List.append [ parent ]
+  in decendants path 
+      |> Overlayfs.delete
+
+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.in_progress 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 (); children = 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 result, work, merged = Path.cache_result t t.next name in
+  t.next <- t.next + 1;
+  let master = Path.cache t name in
+  (* Create cache if it doesn't already exist. *)
+  (match Os.check_dir master with
+  | `Missing -> Overlayfs.create ~mode:"1777" ~user [ master ]
+  | `Present -> Lwt.return_unit)
+  >>= fun () ->
+  cache.children <- cache.children + 1;
+  Overlayfs.create ~mode:"1777" ~user [ result; work; merged ] >>= fun () ->
+  let lower = String.split_on_char ':' master |> String.concat "\\:" in
+  Overlayfs.overlay ~lower ~upper:result ~work ~merged >>= fun () ->
+  let release () =
+    Lwt_mutex.with_lock cache.lock @@ fun () ->
+       cache.children <- cache.children - 1;
+       Overlayfs.umount ~merged >>= fun () ->
+       Overlayfs.cp ~src:result ~dst:master >>= fun () ->
+       Overlayfs.delete [ result; work; merged ]
+  in
+  Lwt.return (merged, release)
+
+let delete_cache t name =
+  let () = Printf.printf "0\n" in
+  let cache = get_cache t name in
+  let () = Printf.printf "1\n" in
+  Lwt_mutex.with_lock cache.lock @@ fun () ->
+  let () = Printf.printf "2\n" in
+  (* Ensures in-progress writes will be discarded *)
+  if cache.children > 0
+  then Lwt_result.fail `Busy
+  else
+    Overlayfs.delete [ Path.cache t name ] >>= fun () ->
+    let () = Printf.printf "3\n" in
+    Lwt.return (Ok ())
+
+let complete_deletes _t = Lwt.return_unit

lib/overlayfs_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 overlayfs store where everything will
+    be stored under [path]. *)