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:
parent
8c62314100
commit
d4da5a199f
4 changed files with 164 additions and 32 deletions
|
|
@ -148,6 +148,26 @@ let access_remove () dbpath username jobname =
|
|||
in
|
||||
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 dbpath = datadir ^ "/builder.sqlite3" in
|
||||
let r =
|
||||
|
|
@ -167,24 +187,7 @@ let job_remove () datadir jobname =
|
|||
let* () =
|
||||
List.fold_left (fun r (build_id, build) ->
|
||||
let* () = r in
|
||||
let dir = Fpath.(v datadir / jobname / Uuidm.to_string build.Builder_db.Build.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 ())
|
||||
build_id
|
||||
in
|
||||
let* () = Db.exec Builder_db.Build_artifact.remove_by_build build_id in
|
||||
Db.exec Builder_db.Build.remove build_id)
|
||||
delete_build datadir (module Db) jobname build_id build.Builder_db.Build.uuid)
|
||||
(Ok ())
|
||||
builds
|
||||
in
|
||||
|
|
@ -202,6 +205,71 @@ let job_remove () datadir jobname =
|
|||
in
|
||||
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 =
|
||||
Caqti_type.unit ->* Builder_db.Rep.cstruct @@
|
||||
"SELECT DISTINCT input_id FROM build WHERE input_id IS NOT NULL"
|
||||
|
|
@ -803,6 +871,12 @@ let build =
|
|||
pos 0 (some string) None &
|
||||
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 doc = "path to write build file" in
|
||||
Cmdliner.Arg.(value & opt string "full" &
|
||||
|
|
@ -876,6 +950,63 @@ let job_remove_cmd =
|
|||
let info = Cmd.info ~doc "job-remove" in
|
||||
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 doc = "extract a build from the database" in
|
||||
let term = Term.(
|
||||
|
|
@ -929,6 +1060,7 @@ let () =
|
|||
verify_input_id_cmd;
|
||||
verify_data_dir_cmd;
|
||||
verify_cache_dir_cmd;
|
||||
extract_full_cmd ]
|
||||
extract_full_cmd;
|
||||
vacuum_cmd ]
|
||||
|> Cmdliner.Cmd.eval
|
||||
|> exit
|
||||
|
|
|
|||
|
|
@ -352,8 +352,8 @@ module Build = struct
|
|||
|}
|
||||
|
||||
let get_builds_older_than =
|
||||
Caqti_type.(tup3 (id `job) (option string) Rep.ptime) ->* t @@
|
||||
{| SELECT uuid, start_d, start_ps, finish_d, finish_ps,
|
||||
Caqti_type.(tup3 (id `job) (option string) Rep.ptime) ->* Caqti_type.tup2 (id `build) t @@
|
||||
{| SELECT id, uuid, start_d, start_ps, finish_d, finish_ps,
|
||||
result_code, result_msg, console, script,
|
||||
platform, main_binary, input_id, user, job
|
||||
FROM build
|
||||
|
|
@ -364,8 +364,8 @@ module Build = struct
|
|||
|}
|
||||
|
||||
let get_builds_excluding_latest_n =
|
||||
Caqti_type.(tup3 (id `job) (option string) int) ->* t @@
|
||||
{| SELECT uuid, start_d, start_ps, finish_d, finish_ps,
|
||||
Caqti_type.(tup3 (id `job) (option string) int) ->* Caqti_type.tup2 (id `build) t @@
|
||||
{| SELECT id, uuid, start_d, start_ps, finish_d, finish_ps,
|
||||
result_code, result_msg, console, script,
|
||||
platform, main_binary, input_id, user, job
|
||||
FROM build
|
||||
|
|
|
|||
|
|
@ -130,9 +130,9 @@ sig
|
|||
([`job] id * string option, t, [ `One | `Zero ])
|
||||
Caqti_request.t
|
||||
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 :
|
||||
([`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 :
|
||||
([`build] id, t, [ `One | `Zero ])
|
||||
Caqti_request.t
|
||||
|
|
|
|||
|
|
@ -281,10 +281,10 @@ let test_get_builds_older_than (module Db : CONN) =
|
|||
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.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 ];
|
||||
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. *)
|
||||
Alcotest.(check (list Testable.uuid)) "last builds" builds [ uuid'; uuid ];
|
||||
Ok ()
|
||||
|
|
@ -293,19 +293,19 @@ let test_builds_excluding_latest_n (module Db : CONN) =
|
|||
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.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 ];
|
||||
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 [];
|
||||
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 [];
|
||||
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 ];
|
||||
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 ];
|
||||
Ok ()
|
||||
|
||||
|
|
|
|||
Loading…
Reference in a new issue