diff --git a/CHANGES.md b/CHANGES.md index 966d252f4d6..d5d1d0e4a82 100644 --- a/CHANGES.md +++ b/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) ------------------ diff --git a/src/cache/local.ml b/src/cache/local.ml index 6259f2ebf6d..dbe1106ab6a 100644 --- a/src/cache/local.ml +++ b/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 diff --git a/src/stdune/temp.ml b/src/stdune/temp.ml index 61d732f04aa..c9956b0b412 100644 --- a/src/stdune/temp.ml +++ b/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) diff --git a/src/stdune/temp.mli b/src/stdune/temp.mli index 12b2e277ed3..c0205fc45db 100644 --- a/src/stdune/temp.mli +++ b/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