Merge pull request #158 from mtelvers/space

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

@@ -274,3 +274,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.