Disk space and number of items in the store

dune-project

@@ -40,6 +40,7 @@
   (crunch (and (>= 3.3.1) :build))
   (obuilder-spec (= :version))
   fpath
+  (extunix (>= 0.4.0))
   (ocaml (>= 4.14.1))
   (alcotest-lwt (and (>= 1.7.0) :with-test))))
 

lib/btrfs_store.ml

@@ -103,6 +103,12 @@ let check_kernel_version () =
 
 let root t = t.root
 
+let df t =
+  Lwt_process.pread ("", [| "btrfs"; "filesystem"; "df"; "-b"; t.root |]) >>= fun s ->
+  match ( Scanf.sscanf s "%s %s total = %Ld , used = %Ld" (fun _ _ t u -> (Int64.to_float u) /. (Int64.to_float t)) ) with
+  | used -> Lwt.return (100. -. (100. *. used))
+  | exception Scanf.Scan_failure _ -> Lwt.return 0.
+
 let create root =
   check_kernel_version () >>= fun () ->
   Os.ensure_dir (root / "result");

lib/build.ml

@@ -272,6 +272,12 @@ module Make (Raw_store : S.STORE) (Sandbox : S.SANDBOX) (Fetch : S.FETCHER) = st
   let prune ?log t ~before limit =
     Store.prune ?log t.store ~before limit
 
+  let count t =
+    Store.count t.store
+
+  let df t =
+    Store.df t.store
+
   let log_to buffer tag x =
     match tag with
     | `Heading | `Note -> Buffer.add_string buffer (x ^ "\n")
@@ -522,6 +528,12 @@ module Make_Docker (Raw_store : S.STORE) = struct
   let prune ?log t ~before limit =
     Store.prune ?log t.store ~before limit
 
+  let count t =
+    Store.count t.store
+
+  let df t =
+    Store.df t.store
+
   let log_to buffer tag x =
     match tag with
     | `Heading | `Note -> Buffer.add_string buffer (x ^ "\n")

lib/dao.ml

@@ -11,6 +11,7 @@ type t = {
   delete : Sqlite3.stmt;
   lru : Sqlite3.stmt;
   parent : Sqlite3.stmt;
+  count : Sqlite3.stmt;
 }
 
 let format_timestamp time =
@@ -41,7 +42,8 @@ let create db =
   let delete = Sqlite3.prepare db {| DELETE FROM builds WHERE id = ? |} in
   let lru = Sqlite3.prepare db {| SELECT id FROM builds WHERE rc = 0 AND used < ? ORDER BY used ASC LIMIT ? |} in
   let parent = Sqlite3.prepare db {| SELECT parent FROM builds WHERE id = ? |} in
-  { db; begin_transaction; commit; rollback; add; set_used; update_rc; exists; children; delete; lru; parent }
+  let count = Sqlite3.prepare db {| SELECT COUNT(*) FROM builds |} in
+  { db; begin_transaction; commit; rollback; add; set_used; update_rc; exists; children; delete; lru; parent; count }
 
 let with_transaction t fn =
   Db.exec t.db t.begin_transaction [];
@@ -91,6 +93,11 @@ let lru t ~before n =
   | Sqlite3.Data.[ TEXT id ] -> id
   | x -> Fmt.failwith "Invalid row: %a" Db.dump_row x
 
+let count t =
+  match Db.query_one t.db t.count [] with
+  | [ INT n ] -> n
+  | x -> Fmt.failwith "Invalid row: %a" Db.dump_row x
+
 let close t =
   Sqlite3.finalize t.begin_transaction |> Db.or_fail t.db ~cmd:"finalize";
   Sqlite3.finalize t.commit |> Db.or_fail t.db ~cmd:"finalize";

lib/db_store.ml

@@ -125,6 +125,8 @@ module Make (Raw : S.STORE) = struct
       Lwt_result.return r
 
   let result t id = Raw.result t.raw id
+  let count t = Dao.count t.dao
+  let df t = Raw.df t.raw
   let cache ~user t = Raw.cache ~user t.raw
 
   let delete ?(log=ignore) t id =

lib/db_store.mli

@@ -20,6 +20,10 @@ module Make (Raw : S.STORE) : sig
 
   val result : t -> S.id -> string option Lwt.t
 
+  val count : t -> int64
+
+  val df : t -> float Lwt.t
+
   val cache :
     user : Obuilder_spec.user ->
     t ->

lib/docker_store.ml

@@ -79,6 +79,8 @@ end
 
 let root t = t.root
 
+let df t = Lwt.return (Os.free_space_percent t.root)
+
 let purge () =
   let* containers = Docker.Cmd.obuilder_containers () in
   let* () = if containers <> [] then Docker.Cmd.rm containers else Lwt.return_unit in

lib/dune

@@ -22,4 +22,4 @@
   (public_name obuilder)
   (preprocess (pps ppx_sexp_conv))
   (flags (:standard -w -69))
-  (libraries fpath lwt lwt.unix fmt yojson tar-unix sexplib sqlite3 astring logs sha obuilder-spec cmdliner))
+  (libraries fpath lwt lwt.unix fmt yojson tar-unix sexplib sqlite3 astring logs sha obuilder-spec cmdliner extunix))

lib/os.ml

@@ -280,3 +280,16 @@ let rec delete_recursively directory =
       | _ -> unlink path
   end >>= fun () ->
   Lwt_unix.rmdir directory
+
+let normalise_path root_dir =
+  if Sys.win32 then
+    let vol, _ = Fpath.(v root_dir |> split_volume) in
+    vol ^ "\\"
+  else
+    root_dir
+
+let free_space_percent root_dir =
+  let vfs = ExtUnix.All.statvfs (normalise_path root_dir) in
+  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))
+

lib/rsync_store.ml

@@ -81,6 +81,8 @@ end
 
 let root t = t.path
 
+let df t = Lwt.return (Os.free_space_percent t.path)
+
 let create ~path ?(mode = Copy) () =
   Rsync.create path >>= fun () ->
   Lwt_list.iter_s Rsync.create (Path.dirs path) >|= fun () ->

lib/s.ml

@@ -16,6 +16,9 @@ module type STORE = sig
   val root : t -> string
   (** [root t] returns the root of the store. *)
 
+  val df : t -> float Lwt.t
+  (** [df t] returns the percentage of free space in the store. *)
+
   val build :
     t -> ?base:id ->
     id:id ->
@@ -114,6 +117,12 @@ module type BUILDER = sig
       Returns the number of items removed.
       @param log Called just before deleting each item, so it can be displayed. *)
 
+  val count : t -> int64
+  (** [count t] return number of items in the store. *)
+
+  val df : t -> float Lwt.t
+  (** [df t] returns the percentage of free space in the store. *)
+
   val healthcheck : ?timeout:float -> t -> (unit, [> `Msg of string]) Lwt_result.t
   (** [healthcheck t] performs a check that [t] is working correctly.
       @param timeout Cancel and report failure after this many seconds.

lib/zfs_store.ml

@@ -143,6 +143,12 @@ let state_dir t = Dataset.path t Dataset.state
 
 let root t = t.pool
 
+let df t =
+  Lwt_process.pread ("", [| "zpool"; "list"; "-Hp"; "-o"; "capacity"; t.pool |]) >>= fun s ->
+  match (String.trim s) with
+  | "" -> Lwt.return 0.
+  | s -> Lwt.return (100. -. float_of_string s)
+
 let prefix_and_pool path =
   let pool = Filename.basename path in
   match Filename.chop_suffix_opt ~suffix:pool path with

obuilder.opam

@@ -37,6 +37,7 @@ depends: [
   "crunch" {>= "3.3.1" & build}
   "obuilder-spec" {= version}
   "fpath"
+  "extunix" {>= "0.4.0"}
   "ocaml" {>= "4.14.1"}
   "alcotest-lwt" {>= "1.7.0" & with-test}
   "odoc" {with-doc}

test/mock_store.ml

@@ -117,3 +117,5 @@ let delete_cache _t _ = assert false
 let complete_deletes _t = Lwt.return_unit
 
 let root t = t.dir
+
+let df _ = Lwt.return 100.