diff --git a/lib/dao.ml b/lib/dao.ml index 41e914f0..9ffbbd6e 100644 --- a/lib/dao.ml +++ b/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 diff --git a/lib/db_store.ml b/lib/db_store.ml index 472ab90c..9cbe81dc 100644 --- a/lib/db_store.ml +++ b/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,7 +129,7 @@ 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); @@ -137,18 +137,23 @@ module Make (Raw : S.STORE) = struct | 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 () ->