From b6304fb1996d380b440e4ec8fa0c5a40320213b7 Mon Sep 17 00:00:00 2001 From: Mark Elvers Date: Fri, 5 May 2023 08:07:27 +0000 Subject: [PATCH 1/5] Added function to return the number of results in obuilder store --- lib/build.ml | 6 ++++++ lib/dao.ml | 9 ++++++++- lib/db_store.ml | 1 + lib/db_store.mli | 2 ++ lib/s.ml | 3 +++ 5 files changed, 20 insertions(+), 1 deletion(-) diff --git a/lib/build.ml b/lib/build.ml index e9103bb0..6c8dcd3b 100644 --- a/lib/build.ml +++ b/lib/build.ml @@ -272,6 +272,9 @@ 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 log_to buffer tag x = match tag with | `Heading | `Note -> Buffer.add_string buffer (x ^ "\n") @@ -522,6 +525,9 @@ 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 log_to buffer tag x = match tag with | `Heading | `Note -> Buffer.add_string buffer (x ^ "\n") diff --git a/lib/dao.ml b/lib/dao.ml index e7342554..4a22d6bf 100644 --- a/lib/dao.ml +++ b/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"; diff --git a/lib/db_store.ml b/lib/db_store.ml index 17978e33..e7c0aef4 100644 --- a/lib/db_store.ml +++ b/lib/db_store.ml @@ -125,6 +125,7 @@ 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 cache ~user t = Raw.cache ~user t.raw let delete ?(log=ignore) t id = diff --git a/lib/db_store.mli b/lib/db_store.mli index 5aae49af..d9085423 100644 --- a/lib/db_store.mli +++ b/lib/db_store.mli @@ -20,6 +20,8 @@ module Make (Raw : S.STORE) : sig val result : t -> S.id -> string option Lwt.t + val count : t -> int64 + val cache : user : Obuilder_spec.user -> t -> diff --git a/lib/s.ml b/lib/s.ml index a1f53daf..e32feb02 100644 --- a/lib/s.ml +++ b/lib/s.ml @@ -114,6 +114,9 @@ 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 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. From 7e947e3c80d831dc586f7dfe2f8e3f152eab4bda Mon Sep 17 00:00:00 2001 From: Mark Elvers Date: Wed, 10 May 2023 16:31:34 +0000 Subject: [PATCH 2/5] Make disk free (df) part of the store --- lib/btrfs_store.ml | 6 ++++++ lib/build.ml | 6 ++++++ lib/db_store.ml | 1 + lib/db_store.mli | 2 ++ lib/docker_store.ml | 2 ++ lib/dune | 2 +- lib/os.ml | 13 +++++++++++++ lib/rsync_store.ml | 2 ++ lib/s.ml | 6 ++++++ lib/zfs_store.ml | 6 ++++++ test/mock_store.ml | 2 ++ 11 files changed, 47 insertions(+), 1 deletion(-) diff --git a/lib/btrfs_store.ml b/lib/btrfs_store.ml index 604a942a..d0524b6d 100644 --- a/lib/btrfs_store.ml +++ b/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"); diff --git a/lib/build.ml b/lib/build.ml index 6c8dcd3b..81f0c69b 100644 --- a/lib/build.ml +++ b/lib/build.ml @@ -275,6 +275,9 @@ module Make (Raw_store : S.STORE) (Sandbox : S.SANDBOX) (Fetch : S.FETCHER) = st 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") @@ -528,6 +531,9 @@ module Make_Docker (Raw_store : S.STORE) = struct 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") diff --git a/lib/db_store.ml b/lib/db_store.ml index e7c0aef4..0157a91c 100644 --- a/lib/db_store.ml +++ b/lib/db_store.ml @@ -126,6 +126,7 @@ module Make (Raw : S.STORE) = struct 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 = diff --git a/lib/db_store.mli b/lib/db_store.mli index d9085423..062e6404 100644 --- a/lib/db_store.mli +++ b/lib/db_store.mli @@ -22,6 +22,8 @@ module Make (Raw : S.STORE) : sig val count : t -> int64 + val df : t -> float Lwt.t + val cache : user : Obuilder_spec.user -> t -> diff --git a/lib/docker_store.ml b/lib/docker_store.ml index 1160320e..8b80fa4b 100644 --- a/lib/docker_store.ml +++ b/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 diff --git a/lib/dune b/lib/dune index a38efaec..9b18fdd1 100644 --- a/lib/dune +++ b/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)) diff --git a/lib/os.ml b/lib/os.ml index a7ed44ec..6bad17c8 100644 --- a/lib/os.ml +++ b/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 (Int64.add used vfs.f_bavail)) + diff --git a/lib/rsync_store.ml b/lib/rsync_store.ml index effa53e2..dfc15b6f 100644 --- a/lib/rsync_store.ml +++ b/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 () -> diff --git a/lib/s.ml b/lib/s.ml index e32feb02..0604252f 100644 --- a/lib/s.ml +++ b/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 -> @@ -117,6 +120,9 @@ module type BUILDER = sig 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. diff --git a/lib/zfs_store.ml b/lib/zfs_store.ml index 69791bbf..09dfa5a1 100644 --- a/lib/zfs_store.ml +++ b/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 diff --git a/test/mock_store.ml b/test/mock_store.ml index 9775543f..fcb5917e 100644 --- a/test/mock_store.ml +++ b/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. From 380eb4df3d1134cc8fb596bcfc0c3f8ce0faaf03 Mon Sep 17 00:00:00 2001 From: Mark Elvers Date: Wed, 10 May 2023 18:11:38 +0000 Subject: [PATCH 3/5] Updated obuilder.opam --- obuilder.opam | 1 + 1 file changed, 1 insertion(+) diff --git a/obuilder.opam b/obuilder.opam index f283a028..38b0e955 100644 --- a/obuilder.opam +++ b/obuilder.opam @@ -37,6 +37,7 @@ depends: [ "crunch" {>= "3.3.1" & build} "obuilder-spec" {= version} "fpath" + "extunix" "ocaml" {>= "4.14.1"} "alcotest-lwt" {>= "1.7.0" & with-test} "odoc" {with-doc} From 5da05e33ca9664f8d43326823b51f8026444f9da Mon Sep 17 00:00:00 2001 From: Mark Elvers Date: Thu, 11 May 2023 16:09:15 +0100 Subject: [PATCH 4/5] Updated df calculation MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-authored-by: Antonin Décimo --- lib/os.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/os.ml b/lib/os.ml index 6bad17c8..6ad1b851 100644 --- a/lib/os.ml +++ b/lib/os.ml @@ -291,5 +291,5 @@ let normalise_path 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 (Int64.add used vfs.f_bavail)) + 100. -. 100. *. (Int64.to_float used) /. Int64.(to_float (add used vfs.f_bavail)) From 1519893c06978a924c205cc9f6f83fb7a792ac09 Mon Sep 17 00:00:00 2001 From: Mark Elvers Date: Fri, 12 May 2023 14:33:08 +0000 Subject: [PATCH 5/5] Added extunix to dune-project --- dune-project | 1 + obuilder.opam | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/dune-project b/dune-project index b09d9adb..6efa8c26 100644 --- a/dune-project +++ b/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)))) diff --git a/obuilder.opam b/obuilder.opam index 38b0e955..44fad1f0 100644 --- a/obuilder.opam +++ b/obuilder.opam @@ -37,7 +37,7 @@ depends: [ "crunch" {>= "3.3.1" & build} "obuilder-spec" {= version} "fpath" - "extunix" + "extunix" {>= "0.4.0"} "ocaml" {>= "4.14.1"} "alcotest-lwt" {>= "1.7.0" & with-test} "odoc" {with-doc}