|
| 1 | +open Stdune |
| 2 | + |
| 3 | +type t = string |
| 4 | + |
| 5 | +external md5_fd : Unix.file_descr -> string = "dune_md5_fd" |
| 6 | + |
| 7 | +module D = Stdlib.Digest |
| 8 | +module Set = String.Set |
| 9 | +module Map = String.Map |
| 10 | +module Metrics = Dune_metrics |
| 11 | + |
| 12 | +module type Digest_impl = sig |
| 13 | + val file : string -> t |
| 14 | + val string : string -> t |
| 15 | +end |
| 16 | + |
| 17 | +module Direct_impl : Digest_impl = struct |
| 18 | + let file file = |
| 19 | + (* On Windows, if this function is invoked in a background thread, |
| 20 | + if can happen that the file is not properly closed. |
| 21 | + [O_SHARE_DELETE] ensures that the main thread can delete it even if it |
| 22 | + is still open. See #8243. *) |
| 23 | + let fd = |
| 24 | + match Unix.openfile file [ Unix.O_RDONLY; O_SHARE_DELETE; O_CLOEXEC ] 0 with |
| 25 | + | fd -> fd |
| 26 | + | exception Unix.Unix_error (Unix.EACCES, _, _) -> |
| 27 | + raise (Sys_error (sprintf "%s: Permission denied" file)) |
| 28 | + | exception exn -> reraise exn |
| 29 | + in |
| 30 | + Exn.protectx fd ~f:md5_fd ~finally:Unix.close |
| 31 | + ;; |
| 32 | + |
| 33 | + let string = D.string |
| 34 | +end |
| 35 | + |
| 36 | +module Mutable_impl = struct |
| 37 | + let file_ref = ref Direct_impl.file |
| 38 | + let string_ref = ref D.string |
| 39 | + let file f = !file_ref f |
| 40 | + let string s = !string_ref s |
| 41 | +end |
| 42 | + |
| 43 | +let override_impl ~file ~string = |
| 44 | + Mutable_impl.file_ref := file; |
| 45 | + Mutable_impl.string_ref := string |
| 46 | +;; |
| 47 | + |
| 48 | +module Impl : Digest_impl = Mutable_impl |
| 49 | + |
| 50 | +let hash = Poly.hash |
| 51 | +let equal = String.equal |
| 52 | +let file p = Impl.file (Path.to_string p) |
| 53 | +let compare x y = Ordering.of_int (D.compare x y) |
| 54 | +let to_string = D.to_hex |
| 55 | +let to_dyn s = Dyn.variant "digest" [ String (to_string s) ] |
| 56 | + |
| 57 | +let from_hex s = |
| 58 | + match D.from_hex s with |
| 59 | + | s -> Some s |
| 60 | + | exception Invalid_argument _ -> None |
| 61 | +;; |
| 62 | + |
| 63 | +let string = Impl.string |
| 64 | +let to_string_raw s = s |
| 65 | + |
| 66 | +(* We use [No_sharing] to avoid generating different digests for inputs that |
| 67 | + differ only in how they share internal values. Without [No_sharing], if a |
| 68 | + command line contains duplicate flags, such as multiple occurrences of the |
| 69 | + flag [-I], then [Marshal.to_string] will produce different digests depending |
| 70 | + on whether the corresponding strings ["-I"] point to the same memory location |
| 71 | + or to different memory locations. *) |
| 72 | +let generic a = |
| 73 | + Metrics.Timer.record "generic_digest" ~f:(fun () -> |
| 74 | + string (Marshal.to_string a [ No_sharing ])) |
| 75 | +;; |
| 76 | + |
| 77 | +let path_with_executable_bit = |
| 78 | + (* We follow the digest scheme used by Jenga. *) |
| 79 | + let string_and_bool ~digest_hex ~bool = |
| 80 | + Impl.string (digest_hex ^ if bool then "\001" else "\000") |
| 81 | + in |
| 82 | + fun ~executable ~content_digest -> |
| 83 | + string_and_bool ~digest_hex:content_digest ~bool:executable |
| 84 | +;; |
| 85 | + |
| 86 | +let file_with_executable_bit ~executable path = |
| 87 | + let content_digest = file path in |
| 88 | + path_with_executable_bit ~content_digest ~executable |
| 89 | +;; |
| 90 | + |
| 91 | +module Stats_for_digest = struct |
| 92 | + type t = |
| 93 | + { st_kind : Unix.file_kind |
| 94 | + ; st_perm : Unix.file_perm |
| 95 | + } |
| 96 | + |
| 97 | + let of_unix_stats (stats : Unix.stats) = |
| 98 | + { st_kind = stats.st_kind; st_perm = stats.st_perm } |
| 99 | + ;; |
| 100 | +end |
| 101 | + |
| 102 | +module Path_digest_error = struct |
| 103 | + type nonrec t = |
| 104 | + | Unexpected_kind |
| 105 | + | Unix_error of Dune_filesystem_stubs.Unix_error.Detailed.t |
| 106 | +end |
| 107 | + |
| 108 | +exception E of Path_digest_error.t |
| 109 | + |
| 110 | +let directory_digest_version = 2 |
| 111 | + |
| 112 | +let path_with_stats ~allow_dirs path (stats : Stats_for_digest.t) = |
| 113 | + let rec loop path (stats : Stats_for_digest.t) = |
| 114 | + match stats.st_kind with |
| 115 | + | S_LNK -> |
| 116 | + let executable = Path.Permissions.test Path.Permissions.execute stats.st_perm in |
| 117 | + Dune_filesystem_stubs.Unix_error.Detailed.catch |
| 118 | + (fun path -> |
| 119 | + let contents = Unix.readlink (Path.to_string path) in |
| 120 | + path_with_executable_bit ~executable ~content_digest:contents) |
| 121 | + path |
| 122 | + |> Result.map_error ~f:(fun x -> Path_digest_error.Unix_error x) |
| 123 | + | S_REG -> |
| 124 | + let executable = Path.Permissions.test Path.Permissions.execute stats.st_perm in |
| 125 | + Dune_filesystem_stubs.Unix_error.Detailed.catch |
| 126 | + (file_with_executable_bit ~executable) |
| 127 | + path |
| 128 | + |> Result.map_error ~f:(fun x -> Path_digest_error.Unix_error x) |
| 129 | + | S_DIR when allow_dirs -> |
| 130 | + (* CR-someday amokhov: The current digesting scheme has collisions for files |
| 131 | + and directories. It's unclear if this is actually a problem. If it turns |
| 132 | + out to be a problem, we should include [st_kind] into both digests. *) |
| 133 | + (match Path.readdir_unsorted path with |
| 134 | + | Error e -> Error (Path_digest_error.Unix_error e) |
| 135 | + | Ok listing -> |
| 136 | + (match |
| 137 | + List.rev_map listing ~f:(fun name -> |
| 138 | + let path = Path.relative path name in |
| 139 | + let stats = |
| 140 | + match Path.lstat path with |
| 141 | + | Error e -> raise_notrace (E (Unix_error e)) |
| 142 | + | Ok stat -> Stats_for_digest.of_unix_stats stat |
| 143 | + in |
| 144 | + let digest = |
| 145 | + match loop path stats with |
| 146 | + | Ok s -> s |
| 147 | + | Error e -> raise_notrace (E e) |
| 148 | + in |
| 149 | + name, digest) |
| 150 | + |> List.sort ~compare:(fun (x, _) (y, _) -> String.compare x y) |
| 151 | + with |
| 152 | + | exception E e -> Error e |
| 153 | + | contents -> Ok (generic (directory_digest_version, contents, stats.st_perm)))) |
| 154 | + | S_DIR | S_BLK | S_CHR | S_FIFO | S_SOCK -> Error Unexpected_kind |
| 155 | + in |
| 156 | + match stats.st_kind with |
| 157 | + | S_DIR when not allow_dirs -> Error Path_digest_error.Unexpected_kind |
| 158 | + | S_BLK | S_CHR | S_LNK | S_FIFO | S_SOCK -> Error Unexpected_kind |
| 159 | + | _ -> loop path stats |
| 160 | +;; |
0 commit comments