Merge pull request 'Add two SQL requests to collect older builds according to a parameter' (#183) from collect-old-builds into main

Reviewed-on: #183

db/builder_db.ml

@@ -203,6 +203,31 @@ module Build = struct
     job_id : [`job] id;
   }
 
+  let pp ppf t =
+    Fmt.pf ppf "@[<hov>{ uuid=@ %a;@ \
+                         start=@ %a;@ \
+                         finish=@ %a;@ \
+                         result=@ @[<hov>%a@];@ \
+                         console=@ %a;@ \
+                         script=@ %a;@ \
+                         platform=@ %S;@ \
+                         main_binary=@ @[<hov>%a@];@ \
+                         input_id=@ @[<hov>%a@];@ \
+                         user_id=@ %Lx;@ \
+                         job_id=@ %Lx;@ }@]"
+      Uuidm.pp t.uuid
+      Ptime.pp t.start
+      Ptime.pp t.finish
+      Builder.pp_execution_result t.result
+      Fpath.pp t.console
+      Fpath.pp t.script
+      t.platform
+      Fmt.(Dump.option int64) t.main_binary
+      Fmt.(Dump.option (using Cstruct.to_string string)) t.input_id
+      t.user_id
+      t.job_id
+
+
   let t =
     let rep =
       Caqti_type.(tup3
@@ -326,6 +351,31 @@ module Build = struct
        LIMIT 1
     |}
 
+  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,
+         result_code, result_msg, console, script,
+         platform, main_binary, input_id, user, job
+       FROM build
+       WHERE job = $1
+         AND ($2 IS NULL OR platform = $2)
+         AND (finish_d < $3 OR (finish_d = $3 AND finish_ps <= $4))
+       ORDER BY start_d DESC, start_ps DESC
+    |}
+
+  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,
+         result_code, result_msg, console, script,
+         platform, main_binary, input_id, user, job
+       FROM build
+       WHERE job = $1
+         AND ($2 IS NULL OR platform = $2)
+       ORDER BY start_d DESC, start_ps DESC
+       LIMIT -1 OFFSET $3
+    |}
+    (* "LIMIT -1 OFFSET n" is all rows except the first n *)
+
   let get_latest_successful =
     Caqti_type.(tup2 (id `job) (option string)) ->? t @@
     {| SELECT

db/builder_db.mli

@@ -110,6 +110,8 @@ sig
     job_id : [`job] id;
   }
 
+  val pp : t Fmt.t
+
   val get_by_uuid :
     (Uuidm.t, [`build] id * t, [ `One | `Zero ])
       Caqti_request.t
@@ -127,6 +129,10 @@ sig
   val get_latest_successful :
     ([`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
+  val get_builds_excluding_latest_n :
+    ([`job] id * string option * int, t, [ `Many | `One | `Zero ]) Caqti_request.t
   val get_previous_successful_different_output :
     ([`build] id, t, [ `One | `Zero ])
       Caqti_request.t

test/dune

@@ -1,7 +1,7 @@
 (test
  (name test_builder_db)
  (modules test_builder_db)
- (libraries builder_db caqti.blocking alcotest mirage-crypto-rng.unix))
+ (libraries ptime.clock.os builder_db caqti.blocking alcotest mirage-crypto-rng.unix))
 
 (test
  (name markdown_to_html)

test/test_builder_db.ml

@@ -276,6 +276,39 @@ let test_artifact_remove_by_build (module Db : CONN) =
   get_opt "no build" >>= fun (id, _build) ->
   Db.exec Builder_db.Build_artifact.remove_by_build id
 
+let test_get_builds_older_than (module Db : CONN) =
+  add_second_build (module Db) >>= fun () ->
+  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
+  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
+  (* NOTE(dinosaure): from the most recent to the older. *)
+  Alcotest.(check (list Testable.uuid)) "last builds" builds [ uuid'; uuid ];
+  Ok ()
+
+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
+  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
+  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
+  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
+  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
+  Alcotest.(check (list Testable.uuid)) "test an incomprehensible argument (-1)" builds [ uuid'; uuid ];
+  Ok ()
+
 let () =
   let open Alcotest in
   Alcotest.run "Builder_db" [
@@ -310,4 +343,8 @@ let () =
       test_case "Other artifact doesn't exists" `Quick (with_build_db test_artifact_exists_false);
       test_case "Remove by build" `Quick (with_build_db test_artifact_remove_by_build);
     ];
+    "vacuum", [
+      test_case "Get builds older than now" `Quick (with_build_db test_get_builds_older_than);
+      test_case "Get older builds and keep a fixed number of then" `Quick (with_build_db test_builds_excluding_latest_n);
+    ]
   ]