Fix temp path creation in Dune cache (#4406)

Fix a race in Dune cache. It was particularly easy to hit this race when using
the cache on Windows, see #4167.

Signed-off-by: Andrey Mokhov <amokhov@janestreet.com>
Signed-off-by: Rudi Grinberg <me@rgrinberg.com>

CHANGES.md

@@ -3,6 +3,9 @@
 
 - Fixed absence of executable bit for installed `.cmxs` (#4149, fixes #4148, @bobot)
 
+- Fix a race in Dune cache. It was particularly easy to hit this race when using
+  the cache on Windows (#4406, fixes #4167, @snowleopard)
+
 2.8.4 (08/03/2021)
 ------------------
 

src/cache/local.ml

@@ -235,47 +235,51 @@ let promote_sync cache paths key metadata ~repository ~duplication =
        [duplication] setting) of the promoted file in a temporary directory to
        correctly handle the situation when the file is modified or deleted
        during the promotion process. *)
-    let tmp =
-      let dst = Path.relative cache.temp_dir "data" in
-      if Path.exists dst then Path.unlink dst;
-      duplicate ~duplication cache ~src:abs_path ~dst;
-      dst
-    in
-    let effective_digest = Digest.file_with_stats tmp (Path.stat tmp) in
-    if Digest.compare effective_digest expected_digest != Ordering.Eq then (
-      let message =
-        Printf.sprintf "digest mismatch: %s != %s"
-          (Digest.to_string effective_digest)
-          (Digest.to_string expected_digest)
-      in
-      cache.info [ Pp.text message ];
-      Result.Error message
-    ) else
-      let in_the_cache = file_path cache effective_digest in
-      (* CR-someday: we assume that if the file with [effective_digest] exists
-         in the file storage, then its content matches the digest, i.e. the user
-         never modifies it. In principle, we could add a consistency check but
-         this would have a non-negligible performance cost. A good compromise
-         seems to be to add a "paranoid" mode to Dune cache where we always
-         check file contents for consistency with the expected digest, so one
-         could enable it when needed. In the paranoid mode, we could furthermore
-         check for a digest collision via [Io.compare_files in_the_cache tmp]. *)
-      match Path.exists in_the_cache with
-      | true ->
-        (* We no longer need the temporary file. *)
-        Path.unlink tmp;
-        (* Update the timestamp of the existing cache entry, moving it to the
-           back of the trimming queue. *)
-        Path.touch in_the_cache;
-        Result.Ok (Already_promoted { path; digest = effective_digest })
-      | false ->
-        Path.mkdir_p (Path.parent_exn in_the_cache);
-        (* Move the temporary file to the cache. *)
-        Path.rename tmp in_the_cache;
-        (* Remove write permissions, making the cache entry immutable. We assume
-           that users do not modify the files in the cache. *)
-        Path.chmod in_the_cache ~mode:(stat.st_perm land 0o555);
-        Result.Ok (Promoted { path; digest = effective_digest })
+    Temp.with_temp_path ~dir:cache.temp_dir ~prefix:"temp" ~suffix:"data"
+      ~f:(function
+      | Error exn ->
+        let message =
+          sprintf "Failed to create a temp file: %s"
+            (Exn.to_dyn exn |> Dyn.to_string)
+        in
+        cache.info [ Pp.text message ];
+        Result.Error message
+      | Ok tmp -> (
+        duplicate ~duplication cache ~src:abs_path ~dst:tmp;
+        let effective_digest = Digest.file_with_stats tmp (Path.stat tmp) in
+        if Digest.compare effective_digest expected_digest != Ordering.Eq then (
+          let message =
+            Printf.sprintf "digest mismatch: %s != %s"
+              (Digest.to_string effective_digest)
+              (Digest.to_string expected_digest)
+          in
+          cache.info [ Pp.text message ];
+          Result.Error message
+        ) else
+          let in_the_cache = file_path cache effective_digest in
+          (* CR-someday: we assume that if the file with [effective_digest]
+             exists in the file storage, then its content matches the digest,
+             i.e. the user never modifies it. In principle, we could add a
+             consistency check but this would have a non-negligible performance
+             cost. A good compromise seems to be to add a "paranoid" mode to
+             Dune cache where we always check file contents for consistency with
+             the expected digest, so one could enable it when needed. In the
+             paranoid mode, we could furthermore check for a digest collision
+             via [Io.compare_files in_the_cache tmp]. *)
+          match Path.exists in_the_cache with
+          | true ->
+            (* Update the timestamp of the existing cache entry, moving it to
+               the back of the trimming queue. *)
+            Path.touch in_the_cache;
+            Result.Ok (Already_promoted { path; digest = effective_digest })
+          | false ->
+            Path.mkdir_p (Path.parent_exn in_the_cache);
+            (* Move the temporary file to the cache. *)
+            Path.rename tmp in_the_cache;
+            (* Remove write permissions, making the cache entry immutable. We
+               assume that users do not modify the files in the cache. *)
+            Path.chmod in_the_cache ~mode:(stat.st_perm land 0o555);
+            Result.Ok (Promoted { path; digest = effective_digest })))
   in
   let+ promoted = Result.List.map ~f:promote paths in
   let metadata_path = metadata_path cache key

src/stdune/temp.ml

@@ -92,3 +92,22 @@ let clear_dir dir =
   in
   remove_from_set ~set:tmp_files;
   remove_from_set ~set:tmp_dirs
+
+let temp_path ~dir ~prefix ~suffix =
+  let rnd = Random.State.bits (Lazy.force prng) land 0xFFFFFF in
+  try_times 1000 ~f:(fun _ ->
+      let candidate =
+        Path.relative dir (Printf.sprintf "%s%06x%s" prefix rnd suffix)
+      in
+      if Path.exists candidate then
+        raise Exit
+      else
+        candidate)
+
+let with_temp_path ~dir ~prefix ~suffix ~f =
+  match temp_path ~dir ~prefix ~suffix with
+  | exception e -> f (Error e)
+  | temp_path ->
+    Exn.protect
+      ~f:(fun () -> f (Ok temp_path))
+      ~finally:(fun () -> Path.unlink_no_err temp_path)

src/stdune/temp.mli

@@ -19,3 +19,18 @@ val destroy : what -> Path.t -> unit
 (** Delete the contents of a temporary directory without deleting the directory
     itself. *)
 val clear_dir : Path.t -> unit
+
+(** [temp_path ~dir ~prefix ~suffix] generate a temporary path in [dir]. The
+    base name of the temporary file is formed by concatenating [prefix], then a
+    suitably chosen integer number, then [suffix]. *)
+val temp_path : dir:Path.t -> prefix:string -> suffix:string -> Path.t
+
+(** Like [temp_path], but passes the temporary file to the callback [f], and
+    makes sure the temporary file is deleted when [f] completes. If [f] raises
+    an exception, the exception is reraised (and the file is still deleted). *)
+val with_temp_path :
+     dir:Path.t
+  -> prefix:string
+  -> suffix:string
+  -> f:((Path.t, exn) result -> 'a)
+  -> 'a