Source file digest.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
type t = string

module D = Stdlib.Digest
module Set = String.Set
module Map = String.Map

module type Digest_impl = sig
  val file : string -> t

  val string : string -> t
end

module Direct_impl : Digest_impl = struct
  let file = D.file

  let string = D.string
end

module Mutable_impl = struct
  let file_ref = ref D.file

  let string_ref = ref D.string

  let file f = !file_ref f

  let string s = !string_ref s
end

let override_impl ~file ~string =
  Mutable_impl.file_ref := file;
  Mutable_impl.string_ref := string

module Impl : Digest_impl = Mutable_impl

let hash = Poly.hash

let equal = String.equal

let file p = Impl.file (Path.to_string p)

let compare x y = Ordering.of_int (D.compare x y)

let to_string = D.to_hex

let to_dyn s = Dyn.variant "digest" [ String (to_string s) ]

let from_hex s =
  match D.from_hex s with
  | s -> Some s
  | exception Invalid_argument _ -> None

let string = Impl.string

let to_string_raw s = s

(* We use [No_sharing] to avoid generating different digests for inputs that
   differ only in how they share internal values. Without [No_sharing], if a
   command line contains duplicate flags, such as multiple occurrences of the
   flag [-I], then [Marshal.to_string] will produce different digests depending
   on whether the corresponding strings ["-I"] point to the same memory location
   or to different memory locations. *)
let generic a =
  Metrics.Timer.record "generic_digest" ~f:(fun () ->
      string (Marshal.to_string a [ No_sharing ]))

let file_with_executable_bit ~executable path =
  (* We follow the digest scheme used by Jenga. *)
  let string_and_bool ~digest_hex ~bool =
    Impl.string (digest_hex ^ if bool then "\001" else "\000")
  in
  let content_digest = file path in
  string_and_bool ~digest_hex:content_digest ~bool:executable

module Stats_for_digest = struct
  type t =
    { st_kind : Unix.file_kind
    ; st_perm : Unix.file_perm
    }

  let of_unix_stats (stats : Unix.stats) =
    { st_kind = stats.st_kind; st_perm = stats.st_perm }
end

module Path_digest_result = struct
  type nonrec t =
    | Ok of t
    | Unexpected_kind
    | Unix_error of Dune_filesystem_stubs.Unix_error.Detailed.t

  let of_result = function
    | Result.Ok t -> Ok t
    | Error unix_error -> Unix_error unix_error

  let equal x y =
    match (x, y) with
    | Ok x, Ok y -> D.equal x y
    | Ok _, _ | _, Ok _ -> false
    | Unexpected_kind, Unexpected_kind -> true
    | Unexpected_kind, _ | _, Unexpected_kind -> false
    | Unix_error x, Unix_error y ->
      Dune_filesystem_stubs.Unix_error.Detailed.equal x y
end

exception
  E of
    [ `Unix_error of Dune_filesystem_stubs.Unix_error.Detailed.t
    | `Unexpected_kind
    ]

let directory_digest_version = 2

let rec path_with_stats ~allow_dirs path (stats : Stats_for_digest.t) :
    Path_digest_result.t =
  match stats.st_kind with
  | S_REG ->
    let executable =
      Path.Permissions.test Path.Permissions.execute stats.st_perm
    in
    Dune_filesystem_stubs.Unix_error.Detailed.catch
      (file_with_executable_bit ~executable)
      path
    |> Path_digest_result.of_result
  | S_DIR when allow_dirs -> (
    (* CR-someday amokhov: The current digesting scheme has collisions for files
       and directories. It's unclear if this is actually a problem. If it turns
       out to be a problem, we should include [st_kind] into both digests. *)
    match Path.readdir_unsorted path with
    | Error e -> Path_digest_result.Unix_error e
    | Ok listing -> (
      match
        List.rev_map listing ~f:(fun name ->
            let path = Path.relative path name in
            let stats =
              match Path.lstat path with
              | Error e -> raise_notrace (E (`Unix_error e))
              | Ok stat -> Stats_for_digest.of_unix_stats stat
            in
            let digest =
              match path_with_stats ~allow_dirs path stats with
              | Ok s -> s
              | Unix_error e -> raise_notrace (E (`Unix_error e))
              | Unexpected_kind -> raise_notrace (E `Unexpected_kind)
            in
            (name, digest))
        |> List.sort ~compare:(fun (x, _) (y, _) -> String.compare x y)
      with
      | exception E (`Unix_error e) -> Path_digest_result.Unix_error e
      | exception E `Unexpected_kind -> Path_digest_result.Unexpected_kind
      | contents ->
        Ok (generic (directory_digest_version, contents, stats.st_perm))))
  | S_DIR | S_BLK | S_CHR | S_LNK | S_FIFO | S_SOCK -> Unexpected_kind