Simplify build log and let store set its location

lib/btrfs_store.ml

@@ -140,8 +140,13 @@ let build t ?base ~id fn =
 let result t id =
   let dir = Path.result t id in
   match Os.check_dir dir with
-  | `Present -> Some dir
-  | `Missing -> None
+  | `Present -> Lwt.return_some dir
+  | `Missing -> Lwt.return_none
+
+let log_file t id =
+  result t id >|= function
+  | Some dir -> dir / "log"
+  | None -> (Path.result_tmp t id) / "log"
 
 let get_cache t name =
   match Hashtbl.find_opt t.caches name with

lib/build.ml

@@ -122,7 +122,7 @@ module Make (Raw_store : S.STORE) (Sandbox : S.SANDBOX) (Fetch : S.FETCHER) = st
         match Scope.find_opt name scope with
         | None -> Fmt.failwith "Unknown build %S" name   (* (shouldn't happen; gets caught earlier) *)
         | Some id ->
-          match Store.result t.store id with
+          Store.result t.store id >>= function
           | None ->
             Lwt_result.fail (`Msg (Fmt.str "Build result %S not found" id))
           | Some dir ->
@@ -233,8 +233,8 @@ module Make (Raw_store : S.STORE) (Sandbox : S.SANDBOX) (Fetch : S.FETCHER) = st
           (Sexplib.Sexp.to_string_hum Saved_context.(sexp_of_t {env})) >>= fun () ->
         Lwt_result.return ()
       )
-    >>!= fun id ->
-    let path = Option.get (Store.result t.store id) in
+    >>!= fun id -> Store.result t.store id
+    >|= Option.get >>= fun path ->
     let { Saved_context.env } = Saved_context.t_of_sexp (Sexplib.Sexp.load_sexp (path / "env")) in
     Lwt_result.return (id, env)
 

lib/build_log.ml

@@ -4,21 +4,13 @@ let max_chunk_size = 4096
 
 type t = {
   mutable state : [
-    | `Open of Lwt_unix.file_descr * unit Lwt_condition.t  (* Fires after writing more data. *)
+    | `Open of string * Lwt_unix.file_descr * unit Lwt_condition.t  (* Fires after writing more data. *)
     | `Readonly of string
     | `Empty
-    | `Finished
   ];
   mutable len : int;
 }
 
-let with_dup fd fn =
-  let fd = Lwt_unix.dup fd in
-  Lwt_unix.set_close_on_exec fd;
-  Lwt.finalize
-    (fun () -> fn fd)
-    (fun () -> Lwt_unix.close fd)
-
 let catch_cancel fn =
   Lwt.catch fn
     (function
@@ -27,34 +19,39 @@ let catch_cancel fn =
     )
 
 let tail ?switch t dst =
-  match t.state with
-  | `Finished -> invalid_arg "tail: log is finished!"
-  | `Readonly path ->
+  let readonly_tail path buf i =
     Lwt_io.(with_file ~mode:input) path @@ fun ch ->
-    let buf = Bytes.create max_chunk_size in
+    Lwt_io.set_position ch (Int64.of_int i) >>= fun () ->
     let rec aux () =
       Lwt_io.read_into ch buf 0 max_chunk_size >>= function
       | 0 -> Lwt_result.return ()
       | n -> dst (Bytes.sub_string buf 0 n); aux ()
     in
+    aux ()
+  in
+  match t.state with
+  | `Readonly path ->
+    let buf = Bytes.create max_chunk_size in
     catch_cancel @@ fun () ->
-    let th = aux () in
+    let th = readonly_tail path buf 0 in
     Lwt_switch.add_hook_or_exec switch (fun () -> Lwt.cancel th; Lwt.return_unit) >>= fun () ->
     th
   | `Empty -> Lwt_result.return ()
-  | `Open (fd, cond) ->
-    (* Dup [fd], which can still work after [fd] is closed. *)
-    with_dup fd @@ fun fd ->
+  | `Open (_, fd, cond) ->
     let buf = Bytes.create max_chunk_size in
     let rec aux i =
       match switch with
       | Some sw when not (Lwt_switch.is_on sw) -> Lwt_result.fail `Cancelled
       | _ ->
         let avail = min (t.len - i) max_chunk_size in
         if avail > 0 then (
-          Lwt_unix.pread fd ~file_offset:i buf 0 avail >>= fun n ->
-          dst (Bytes.sub_string buf 0 n);
-          aux (i + avail)
+          match t.state with
+          | `Open _ ->
+            Lwt_unix.pread fd ~file_offset:i buf 0 avail >>= fun n ->
+            dst (Bytes.sub_string buf 0 n);
+            aux (i + avail)
+          | `Readonly path -> readonly_tail path buf i
+          | _ -> Lwt_result.return ()
         ) else (
           match t.state with
           | `Open _ -> Lwt_condition.wait cond >>= fun () -> aux i
@@ -70,28 +67,25 @@ let create path =
   Lwt_unix.openfile path Lwt_unix.[O_CREAT; O_TRUNC; O_RDWR; O_CLOEXEC] 0o666 >|= fun fd ->
   let cond = Lwt_condition.create () in
   {
-    state = `Open (fd, cond);
+    state = `Open (path, fd, cond);
     len = 0;
   }
 
 let finish t =
   match t.state with
-  | `Finished -> invalid_arg "Log is already finished!"
-  | `Open (fd, cond) ->
-    t.state <- `Finished;
+  | `Open (path, fd, cond) ->
+    t.state <- `Readonly path;
     Lwt_unix.close fd >|= fun () ->
     Lwt_condition.broadcast cond ()
   | `Readonly _ ->
-    t.state <- `Finished;
     Lwt.return_unit
   | `Empty ->
     Lwt.return_unit (* Empty can be reused *)
 
 let write t data =
   match t.state with
-  | `Finished -> invalid_arg "write: log is finished!"
   | `Readonly _ | `Empty -> invalid_arg "Log is read-only!"
-  | `Open (fd, cond) ->
+  | `Open (_, fd, cond) ->
     let len = String.length data in
     Os.write_all fd (Bytes.of_string data) 0 len >>= fun () ->
     t.len <- t.len + len;

lib/db_store.ml

@@ -46,11 +46,11 @@ module Make (Raw : S.STORE) = struct
      or by doing a new build using [fn]. We only run one instance of this
      at a time for a single [id]. *)
   let get_build t ~base ~id ~cancelled ~set_log fn =
-    match Raw.result t.raw id with
-    | Some dir ->
+    Raw.result t.raw id >>= function
+    | Some _ ->
       let now = Unix.(gmtime (gettimeofday ())) in
       Dao.set_used t.dao ~id ~now;
-      let log_file = dir / "log" in
+      Raw.log_file t.raw id >>= fun log_file ->
       begin
         if Sys.file_exists log_file then Build_log.of_saved log_file
         else Lwt.return Build_log.empty
@@ -59,7 +59,7 @@ module Make (Raw : S.STORE) = struct
       Lwt_result.return (`Loaded, id)
     | None ->
       Raw.build t.raw ?base ~id (fun dir ->
-          let log_file = dir / "log" in
+          Raw.log_file t.raw id >>= fun log_file ->
           if Sys.file_exists log_file then Unix.unlink log_file;
           Build_log.create log_file >>= fun log ->
           Lwt.wakeup set_log log;

lib/db_store.mli

@@ -18,7 +18,7 @@ module Make (Raw : S.STORE) : sig
 
   val prune : ?log:(S.id -> unit) -> t -> before:Unix.tm -> int -> int Lwt.t
 
-  val result : t -> S.id -> string option
+  val result : t -> S.id -> string option Lwt.t
 
   val cache :
     user : Obuilder_spec.user ->

lib/rsync_store.ml

@@ -98,8 +98,13 @@ let delete t id =
 let result t id =
   let dir = Path.result t id in
   match Os.check_dir dir with
-  | `Present -> Some dir
-  | `Missing -> None
+  | `Present -> Lwt.return_some dir
+  | `Missing -> Lwt.return_none
+
+let log_file t id =
+  result t id >|= function
+  | Some dir -> dir / "log"
+  | None -> (Path.result_tmp t id) / "log"
 
 let state_dir t = t.path / Path.state_dirname
 

lib/s.ml

@@ -31,9 +31,13 @@ module type STORE = sig
   val delete : t -> id -> unit Lwt.t
   (** [delete t id] removes [id] from the store, if present. *)
 
-  val result : t -> id -> string option
+  val result : t -> id -> string option Lwt.t
   (** [result t id] is the path of the build result for [id], if present. *)
 
+  val log_file : t -> id -> string Lwt.t
+  (** [log_file t id] is the path of the build logs for [id]. The file may
+      not exist if the build has never been run, or failed. *)
+
   val state_dir : t -> string
   (** [state_dir] is the path of a directory which can be used to store mutable
       state related to this store (e.g. an sqlite3 database). *)

lib/zfs_store.ml

@@ -202,8 +202,16 @@ let build t ?base ~id fn =
 let result t id =
   let ds = Dataset.result id in
   let path = Dataset.path t ds ~snapshot:default_snapshot in
-  if Sys.file_exists path then Some path
-  else None
+  if Sys.file_exists path then Lwt.return_some path
+  else Lwt.return_none
+
+let log_file t id =
+  result t id >|= function
+  | Some dir -> Filename.concat dir "log"
+  | None ->
+    let ds = Dataset.result id in
+    let clone = Dataset.path t ds in
+    Filename.concat clone "log"
 
 let get_cache t name =
   match Hashtbl.find_opt t.caches name with

stress/stress.ml

@@ -21,38 +21,39 @@ module Fetcher = Docker
 
 module Test(Store : S.STORE) = struct
   let assert_output expected t id =
-    match Store.result t id with
+    Store.result t id >>= function
     | None -> Fmt.failwith "%S not in store!" id
     | Some path ->
       let ch = open_in (path / "output") in
       let data = really_input_string ch (in_channel_length ch) in
       close_in ch;
-      assert_str expected data
+      assert_str expected data;
+      Lwt.return_unit
 
   let test_store t =
-    assert (Store.result t "unknown" = None);
+    Store.result t "unknown" >>= fun r -> assert (r = None);
     (* Build without a base *)
     Store.delete t "base" >>= fun () ->
     Store.build t ~id:"base" (fun tmpdir -> write ~path:(tmpdir / "output") "ok" >|= Result.ok) >>= fun r ->
     assert (r = Ok ());
-    assert_output "ok" t "base";
+    assert_output "ok" t "base" >>= fun () ->
     (* Build with a base *)
     Store.delete t "sub" >>= fun () ->
     Store.build t ~base:"base" ~id:"sub" (fun tmpdir ->
         read (tmpdir / "output") >>= fun orig ->
         write ~path:(tmpdir / "output") (orig ^ "+") >|= Result.ok
       ) >>= fun r ->
     assert (r = Ok ());
-    assert_output "ok+" t "sub";
+    assert_output "ok+" t "sub" >>= fun () ->
     (* Test deletion *)
-    assert (Store.result t "sub" <> None);
+    Store.result t "sub" >>= fun r -> assert (r <> None);
     Store.delete t "sub" >>= fun () ->
-    assert (Store.result t "sub" = None);
+    Store.result t "sub" >>= fun r -> assert (r = None);
     (* A failing build isn't saved *)
     Store.delete t "fail" >>= fun () ->
     Store.build t ~id:"fail" (fun _tmpdir -> Lwt_result.fail `Failed) >>= fun r ->
     assert (r = Error `Failed);
-    assert (Store.result t "fail" = None);
+    Store.result t "fail" >>= fun r -> assert (r = None);
     Lwt.return_unit
 
   let test_cache t =

test/mock_store.ml

@@ -61,8 +61,13 @@ let path t id = t.dir / id
 let result t id =
   let dir = path t id in
   match Os.check_dir dir with
-  | `Present -> Some dir
-  | `Missing -> None
+  | `Present -> Lwt.return_some dir
+  | `Missing -> Lwt.return_none
+
+let log_file t id =
+  result t id >|= function
+  | Some dir -> dir / "log"
+  | None -> t.dir / (id ^ "-tmp") / "log"
 
 let rec finish t =
   if t.builds > 0 then (
@@ -80,7 +85,7 @@ let with_store fn =
     (fun () -> finish t)
 
 let delete t id =
-  match result t id with
+  result t id >>= function
   | Some path -> rm_r path; Lwt.return_unit
   | None -> Lwt.return_unit