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 () ->