Implement builder-db vacuum {older-than,latest-n}

- `builder-db vacuum older-than [--job JOBNAME] RFC3339` removes all
  builds in `JOBNAME` (defaults to all jobs) that were built before
  `RFC3339`.
- `builder-db vacuum except-latest [--job JOBNAME] LATEST-N` removes all
  builds in `JOBNNAME` (defaults to all jobs) except for the latest
  `LATEST-N` builds (successful or not).
This commit is contained in:
Reynir Björnsson 2024-02-12 14:59:57 +01:00
parent 8c62314100
commit d4da5a199f
4 changed files with 164 additions and 32 deletions

View file

@ -148,6 +148,26 @@ let access_remove () dbpath username jobname =
in in
or_die 1 r or_die 1 r
let delete_build datadir (module Db : Caqti_blocking.CONNECTION) jobname id uuid =
let dir = Fpath.(v datadir / jobname / Uuidm.to_string uuid) in
(match Bos.OS.Dir.delete ~recurse:true dir with
| Ok _ -> ()
| Error `Msg e -> Logs.warn (fun m -> m "failed to remove build directory %a: %s" Fpath.pp dir e));
let* () =
Db.iter_s build_artifacts_to_orphan
(fun sha256 ->
let p = Fpath.(v datadir // artifact_path sha256) in
match Bos.OS.Path.delete p with
| Ok () -> Ok ()
| Error `Msg e ->
Logs.warn (fun m -> m "failed to remove orphan artifact %a: %s"
Fpath.pp p e);
Ok ())
id
in
let* () = Db.exec Builder_db.Build_artifact.remove_by_build id in
Db.exec Builder_db.Build.remove id
let job_remove () datadir jobname = let job_remove () datadir jobname =
let dbpath = datadir ^ "/builder.sqlite3" in let dbpath = datadir ^ "/builder.sqlite3" in
let r = let r =
@ -167,24 +187,7 @@ let job_remove () datadir jobname =
let* () = let* () =
List.fold_left (fun r (build_id, build) -> List.fold_left (fun r (build_id, build) ->
let* () = r in let* () = r in
let dir = Fpath.(v datadir / jobname / Uuidm.to_string build.Builder_db.Build.uuid) in delete_build datadir (module Db) jobname build_id build.Builder_db.Build.uuid)
(match Bos.OS.Dir.delete ~recurse:true dir with
| Ok _ -> ()
| Error `Msg e -> Logs.warn (fun m -> m "failed to remove build directory %a: %s" Fpath.pp dir e));
let* () =
Db.iter_s build_artifacts_to_orphan
(fun sha256 ->
let p = Fpath.(v datadir // artifact_path sha256) in
match Bos.OS.Path.delete p with
| Ok () -> Ok ()
| Error `Msg e ->
Logs.warn (fun m -> m "failed to remove orphan artifact %a: %s"
Fpath.pp p e);
Ok ())
build_id
in
let* () = Db.exec Builder_db.Build_artifact.remove_by_build build_id in
Db.exec Builder_db.Build.remove build_id)
(Ok ()) (Ok ())
builds builds
in in
@ -202,6 +205,71 @@ let job_remove () datadir jobname =
in in
or_die 1 r or_die 1 r
let vacuum datadir (module Db : Caqti_blocking.CONNECTION) platform_opt job_id predicate =
let* jobname = Db.find Builder_db.Job.get job_id in
let* builds =
match predicate with
| `Date older_than ->
Db.collect_list Builder_db.Build.get_builds_older_than (job_id, platform_opt, older_than)
| `Latest latest_n ->
Db.collect_list Builder_db.Build.get_builds_excluding_latest_n (job_id, platform_opt, latest_n)
(* TODO: | `Latest_successful latest_n -> ... *)
in
let* () =
List.fold_left (fun r (build_id, build) ->
let* () = r in
let* () = Db.start () in
let* () = Db.exec defer_foreign_keys () in
match
delete_build datadir (module Db) jobname build_id
build.Builder_db.Build.uuid
with
| Ok () -> Db.commit ()
| Error _ as e ->
let* () = Db.rollback () in
e)
(Ok ())
builds
in
Db.commit ()
let vacuum () datadir platform_opt jobnames predicate =
let dbpath = datadir ^ "/builder.sqlite3" in
let r =
let* (module Db : Caqti_blocking.CONNECTION) =
connect (Uri.make ~scheme:"sqlite3" ~path:dbpath ~query:["create", ["false"]] ())
in
let* jobs =
match jobnames with
| [] ->
(* We default to all jobs if no jobnames were specified *)
let* jobs = Db.collect_list Builder_db.Job.get_all_with_section_synopsis () in
Ok (List.map (fun (job_id, _, _, _) -> job_id) jobs)
| _ :: _ ->
let* (jobs, unknown_jobnames) =
List.fold_left
(fun r jobname ->
let* (jobs, unknown_jobnames) = r in
let* job_id_opt = Db.find_opt Builder_db.Job.get_id_by_name jobname in
match job_id_opt with
| Some job_id -> Ok (job_id :: jobs, unknown_jobnames)
| None -> Ok (jobs, jobname :: unknown_jobnames))
(Ok ([], []))
jobnames
in
match unknown_jobnames with
| [] -> Ok jobs
| _ :: _ ->
Error (`Msg ("Unknown job(s): " ^ String.concat ", " unknown_jobnames))
in
List.fold_left (fun r jobid ->
let* () = r in
vacuum datadir (module Db) platform_opt jobid predicate)
(Ok ())
jobs
in
or_die 1 r
let input_ids = let input_ids =
Caqti_type.unit ->* Builder_db.Rep.cstruct @@ Caqti_type.unit ->* Builder_db.Rep.cstruct @@
"SELECT DISTINCT input_id FROM build WHERE input_id IS NOT NULL" "SELECT DISTINCT input_id FROM build WHERE input_id IS NOT NULL"
@ -803,6 +871,12 @@ let build =
pos 0 (some string) None & pos 0 (some string) None &
info ~doc ~docv:"BUILD" []) info ~doc ~docv:"BUILD" [])
let platform =
let doc = "platform" in
Cmdliner.Arg.(value &
opt (some string) None &
info ~doc ~docv:"PLATFORM" ["platform"])
let full_dest = let full_dest =
let doc = "path to write build file" in let doc = "path to write build file" in
Cmdliner.Arg.(value & opt string "full" & Cmdliner.Arg.(value & opt string "full" &
@ -876,6 +950,63 @@ let job_remove_cmd =
let info = Cmd.info ~doc "job-remove" in let info = Cmd.info ~doc "job-remove" in
Cmd.v info term Cmd.v info term
let vacuum_cmd =
let jobnames =
Arg.(value & opt_all string [] & info ~doc:"jobs" ~docv:"JOB" [])
in
let ptime_conv =
let parse s =
match Ptime.of_rfc3339 s with
| Ok (ptime, (None | Some 0), _) ->
Ok (`Date ptime)
| Ok _ -> Error (`Msg "only UTC timezone is allowed")
| Error `RFC3339 (_range, e) ->
Error (`Msg (Format.asprintf "bad RFC3339 date-time: %a" Ptime.pp_rfc3339_error e))
and pp ppf (`Date ptime) =
Ptime.pp_rfc3339 () ppf ptime
in
Arg.conv (parse, pp)
in
let older_than =
let doc = "cut-off date-time" in
Arg.(required & pos 0 (some ptime_conv) None & info ~doc ~docv:"OLDER-THAN" [])
in
let latest_n =
let doc = "latest N" in
let latest_n =
let parse s =
match Arg.(conv_parser int) s with
| Ok n when n > 0 -> Ok (`Latest n)
| Ok _ -> Error (`Msg "must be positive integer")
| Error _ as e -> e
and pp ppf (`Latest n) =
Arg.(conv_printer int) ppf n
in
Arg.conv (parse, pp)
in
Arg.(required & pos 0 (some latest_n) None & info ~doc ~docv:"LATEST-N" [])
in
let vacuum_older_than =
let doc = "vacuum builds older than a date" in
let info = Cmd.info ~doc "older-than" in
let term =
Term.(const vacuum $ setup_log $ datadir $ platform $ jobnames $ older_than)
in
Cmd.v info term
in
let vacuum_except_latest_n =
let doc = "vacuum all builds except for the latest N builds (successful or not)" in
let info = Cmd.info ~doc "except-latest" in
let term =
Term.(const vacuum $ setup_log $ datadir $ platform $ jobnames $ latest_n)
in
Cmd.v info term
in
Cmd.group (Cmd.info "vacuum") [
vacuum_older_than;
vacuum_except_latest_n
]
let extract_full_cmd = let extract_full_cmd =
let doc = "extract a build from the database" in let doc = "extract a build from the database" in
let term = Term.( let term = Term.(
@ -929,6 +1060,7 @@ let () =
verify_input_id_cmd; verify_input_id_cmd;
verify_data_dir_cmd; verify_data_dir_cmd;
verify_cache_dir_cmd; verify_cache_dir_cmd;
extract_full_cmd ] extract_full_cmd;
vacuum_cmd ]
|> Cmdliner.Cmd.eval |> Cmdliner.Cmd.eval
|> exit |> exit

View file

@ -352,8 +352,8 @@ module Build = struct
|} |}
let get_builds_older_than = let get_builds_older_than =
Caqti_type.(tup3 (id `job) (option string) Rep.ptime) ->* t @@ Caqti_type.(tup3 (id `job) (option string) Rep.ptime) ->* Caqti_type.tup2 (id `build) t @@
{| SELECT uuid, start_d, start_ps, finish_d, finish_ps, {| SELECT id, uuid, start_d, start_ps, finish_d, finish_ps,
result_code, result_msg, console, script, result_code, result_msg, console, script,
platform, main_binary, input_id, user, job platform, main_binary, input_id, user, job
FROM build FROM build
@ -364,8 +364,8 @@ module Build = struct
|} |}
let get_builds_excluding_latest_n = let get_builds_excluding_latest_n =
Caqti_type.(tup3 (id `job) (option string) int) ->* t @@ Caqti_type.(tup3 (id `job) (option string) int) ->* Caqti_type.tup2 (id `build) t @@
{| SELECT uuid, start_d, start_ps, finish_d, finish_ps, {| SELECT id, uuid, start_d, start_ps, finish_d, finish_ps,
result_code, result_msg, console, script, result_code, result_msg, console, script,
platform, main_binary, input_id, user, job platform, main_binary, input_id, user, job
FROM build FROM build

View file

@ -130,9 +130,9 @@ sig
([`job] id * string option, t, [ `One | `Zero ]) ([`job] id * string option, t, [ `One | `Zero ])
Caqti_request.t Caqti_request.t
val get_builds_older_than : val get_builds_older_than :
([`job] id * string option * Ptime.t, t, [ `Many | `One | `Zero ]) Caqti_request.t ([`job] id * string option * Ptime.t, [`build] id * t, [ `Many | `One | `Zero ]) Caqti_request.t
val get_builds_excluding_latest_n : val get_builds_excluding_latest_n :
([`job] id * string option * int, t, [ `Many | `One | `Zero ]) Caqti_request.t ([`job] id * string option * int, [`build] id * t, [ `Many | `One | `Zero ]) Caqti_request.t
val get_previous_successful_different_output : val get_previous_successful_different_output :
([`build] id, t, [ `One | `Zero ]) ([`build] id, t, [ `One | `Zero ])
Caqti_request.t Caqti_request.t

View file

@ -281,10 +281,10 @@ let test_get_builds_older_than (module Db : CONN) =
let date = Option.get (Ptime.of_float_s (3600. /. 2.)) in let date = Option.get (Ptime.of_float_s (3600. /. 2.)) in
Db.find_opt Builder_db.Job.get_id_by_name job_name >>= fail_if_none >>= fun job_id -> Db.find_opt Builder_db.Job.get_id_by_name job_name >>= fail_if_none >>= fun job_id ->
Db.collect_list Builder_db.Build.get_builds_older_than (job_id, None, date) >>= fun builds -> Db.collect_list Builder_db.Build.get_builds_older_than (job_id, None, date) >>= fun builds ->
let builds = List.map (fun { Builder_db.Build.uuid; _ } -> uuid) builds in let builds = List.map (fun (_, { Builder_db.Build.uuid; _ }) -> uuid) builds in
Alcotest.(check (list Testable.uuid)) "last build" builds [ uuid ]; Alcotest.(check (list Testable.uuid)) "last build" builds [ uuid ];
Db.collect_list Builder_db.Build.get_builds_older_than (job_id, None, Ptime_clock.now ()) >>= fun builds -> Db.collect_list Builder_db.Build.get_builds_older_than (job_id, None, Ptime_clock.now ()) >>= fun builds ->
let builds = List.map (fun { Builder_db.Build.uuid; _ } -> uuid) builds in let builds = List.map (fun (_, { Builder_db.Build.uuid; _ }) -> uuid) builds in
(* NOTE(dinosaure): from the most recent to the older. *) (* NOTE(dinosaure): from the most recent to the older. *)
Alcotest.(check (list Testable.uuid)) "last builds" builds [ uuid'; uuid ]; Alcotest.(check (list Testable.uuid)) "last builds" builds [ uuid'; uuid ];
Ok () Ok ()
@ -293,19 +293,19 @@ let test_builds_excluding_latest_n (module Db : CONN) =
add_second_build (module Db) >>= fun () -> add_second_build (module Db) >>= fun () ->
Db.find_opt Builder_db.Job.get_id_by_name job_name >>= fail_if_none >>= fun job_id -> Db.find_opt Builder_db.Job.get_id_by_name job_name >>= fail_if_none >>= fun job_id ->
Db.collect_list Builder_db.Build.get_builds_excluding_latest_n (job_id, None, 1) >>= fun builds -> Db.collect_list Builder_db.Build.get_builds_excluding_latest_n (job_id, None, 1) >>= fun builds ->
let builds = List.map (fun { Builder_db.Build.uuid; _ } -> uuid) builds in let builds = List.map (fun (_, { Builder_db.Build.uuid; _ }) -> uuid) builds in
Alcotest.(check (list Testable.uuid)) "keep recent build" builds [ uuid ]; Alcotest.(check (list Testable.uuid)) "keep recent build" builds [ uuid ];
Db.collect_list Builder_db.Build.get_builds_excluding_latest_n (job_id, None, 2) >>= fun builds -> Db.collect_list Builder_db.Build.get_builds_excluding_latest_n (job_id, None, 2) >>= fun builds ->
let builds = List.map (fun { Builder_db.Build.uuid; _ } -> uuid) builds in let builds = List.map (fun (_, { Builder_db.Build.uuid; _ }) -> uuid) builds in
Alcotest.(check (list Testable.uuid)) "keep 2 builds" builds []; Alcotest.(check (list Testable.uuid)) "keep 2 builds" builds [];
Db.collect_list Builder_db.Build.get_builds_excluding_latest_n (job_id, None, 3) >>= fun builds -> Db.collect_list Builder_db.Build.get_builds_excluding_latest_n (job_id, None, 3) >>= fun builds ->
let builds = List.map (fun { Builder_db.Build.uuid; _ } -> uuid) builds in let builds = List.map (fun (_, { Builder_db.Build.uuid; _ }) -> uuid) builds in
Alcotest.(check (list Testable.uuid)) "last more builds than we have" builds []; Alcotest.(check (list Testable.uuid)) "last more builds than we have" builds [];
Db.collect_list Builder_db.Build.get_builds_excluding_latest_n (job_id, None, 0) >>= fun builds -> Db.collect_list Builder_db.Build.get_builds_excluding_latest_n (job_id, None, 0) >>= fun builds ->
let builds = List.map (fun { Builder_db.Build.uuid; _ } -> uuid) builds in let builds = List.map (fun (_, { Builder_db.Build.uuid; _ }) -> uuid) builds in
Alcotest.(check (list Testable.uuid)) "delete all builds" builds [ uuid'; uuid ]; Alcotest.(check (list Testable.uuid)) "delete all builds" builds [ uuid'; uuid ];
Db.collect_list Builder_db.Build.get_builds_excluding_latest_n (job_id, None, -1) >>= fun builds -> Db.collect_list Builder_db.Build.get_builds_excluding_latest_n (job_id, None, -1) >>= fun builds ->
let builds = List.map (fun { Builder_db.Build.uuid; _ } -> uuid) builds in let builds = List.map (fun (_, { Builder_db.Build.uuid; _ }) -> uuid) builds in
Alcotest.(check (list Testable.uuid)) "test an incomprehensible argument (-1)" builds [ uuid'; uuid ]; Alcotest.(check (list Testable.uuid)) "test an incomprehensible argument (-1)" builds [ uuid'; uuid ];
Ok () Ok ()