Filter out jobs in progress when pruning Db_store

lib/dao.ml

@@ -13,6 +13,15 @@ type t = {
  parent : Sqlite3.stmt;
 }
 
+let m = Mutex.create ()
+
+let thread_detach f =
+ Lwt_preemptive.detach (fun () ->
+ Mutex.lock m;
+ Fun.protect f
+ ~finally:(fun () -> Mutex.unlock m)
+ ) ()
+
 let format_timestamp time =
  let { Unix.tm_year; tm_mon; tm_mday; tm_hour; tm_min; tm_sec; _ } = time in
  Fmt.str "%04d-%02d-%02d %02d:%02d:%02d" (tm_year + 1900) (tm_mon + 1) tm_mday tm_hour tm_min tm_sec
@@ -50,6 +59,7 @@ let with_transaction t fn =
  | exception ex -> Db.exec t.rollback []; raise ex
 
 let add ?parent ~id ~now t =
+ thread_detach @@ fun () ->
  let now = format_timestamp now in
  match parent with
  | None -> Db.exec t.add Sqlite3.Data.[ TEXT id; TEXT now; TEXT now; NULL ];
@@ -60,10 +70,12 @@ let add ?parent ~id ~now t =
  )
 
 let set_used ~id ~now t =
+ thread_detach @@ fun () ->
  let now = format_timestamp now in
  Db.exec t.set_used Sqlite3.Data.[ TEXT now; TEXT id ]
 
 let children t id =
+ thread_detach @@ fun () ->
  match Db.query_one t.exists Sqlite3.Data.[ TEXT id ] with
  | [ INT 0L ] -> Error `No_such_id
  | [ INT 1L ] ->
@@ -75,6 +87,7 @@ let children t id =
  | x -> Fmt.failwith "Invalid row: %a" Db.dump_row x
 
 let delete t id =
+ thread_detach @@ fun () ->
  with_transaction t (fun () ->
  match Db.query_one t.parent Sqlite3.Data.[ TEXT id ] with
  | [ TEXT parent ] ->
@@ -86,6 +99,7 @@ let delete t id =
  )
 
 let lru t ~before n =
+ thread_detach @@ fun () ->
  Db.query t.lru Sqlite3.Data.[ TEXT (format_timestamp before); INT (Int64.of_int n) ]
  |> List.map @@ function
  | Sqlite3.Data.[ TEXT id ] -> id

lib/db_store.ml

@@ -48,7 +48,7 @@ module Make (Raw : S.STORE) = struct
  match Raw.result t.raw id with
  | Some dir ->
  let now = Unix.(gmtime (gettimeofday ())) in
- Dao.set_used t.dao ~id ~now;
+ Dao.set_used t.dao ~id ~now >>= fun () ->
  let log_file = dir / "log" in
  begin
  if Sys.file_exists log_file then Build_log.of_saved log_file
@@ -66,7 +66,7 @@ module Make (Raw : S.STORE) = struct
  )
  >>!= fun () ->
  let now = Unix.(gmtime (gettimeofday () )) in
- Dao.add t.dao ?parent:base ~id ~now;
+ Dao.add t.dao ?parent:base ~id ~now >>= fun () ->
  Lwt_result.return (`Saved, id)
 
  let log_ty client_log ~id = function
@@ -129,26 +129,31 @@ module Make (Raw : S.STORE) = struct
 
  let delete ?(log=ignore) t id =
  let rec aux id =
- match Dao.children t.dao id with
+ Dao.children t.dao id >>= function
  | Error `No_such_id ->
  log id;
  Log.warn (fun f -> f "ID %S not in database!" id);
  Raw.delete t.raw id (* Try removing it anyway *)
  | Ok deps ->
  Lwt_list.iter_s aux deps >>= fun () ->
  log id;
- Raw.delete t.raw id >|= fun () ->
+ Raw.delete t.raw id >>= fun () ->
  Dao.delete t.dao id
  in
- aux id
+ if Builds.mem id t.in_progress then begin
+ Log.warn (fun f -> f "Trying to delete ID %S but it is still in progress!" id);
+ Lwt.return_unit (* Ignore the deletion if the job is still in progress *)
+ end else
+ aux id
 
  let prune_batch ?(log=ignore) t ~before limit =
- let items = Dao.lru t.dao ~before limit in
+ Dao.lru t.dao ~before limit >>= fun items ->
+ let items = List.filter (fun id -> not (Builds.mem id t.in_progress)) items in
  let n = List.length items in
  Log.info (fun f -> f "Pruning %d items (of %d requested)" n limit);
  items |> Lwt_list.iter_s (fun id ->
  log id;
- Raw.delete t.raw id >|= fun () ->
+ Raw.delete t.raw id >>= fun () ->
  Dao.delete t.dao id
  )
  >>= fun () ->