Source file md5.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
module T = struct
  include Bin_prot.Md5

  let sexp_of_t t = t |> to_hex |> String.sexp_of_t
  let t_of_sexp s = s |> String.t_of_sexp |> of_hex_exn
  let t_sexp_grammar = Sexplib.Sexp_grammar.coerce String.t_sexp_grammar
end

let hash_fold_t accum t = String.hash_fold_t accum (T.to_binary t)
let hash t = String.hash (T.to_binary t)

module As_binary_string = struct
  module Stable = struct
    module V1 = struct
      type t = T.t [@@deriving compare]

      let hash_fold_t = hash_fold_t
      let hash = hash
      let sexp_of_t x = String.sexp_of_t (T.to_binary x)
      let t_of_sexp x = T.of_binary_exn (String.t_of_sexp x)
      let t_sexp_grammar = Sexplib.Sexp_grammar.coerce String.t_sexp_grammar

      include Bin_prot.Utils.Make_binable_without_uuid [@alert "-legacy"] (struct
          module Binable = String

          type t = Bin_prot.Md5.t

          let to_binable = T.to_binary
          let of_binable = T.of_binary_exn
        end)
    end
  end

  include Stable.V1
  include Comparable.Make (Stable.V1)
  include Hashable.Make (Stable.V1)
end

module Stable = struct
  module V1 = struct
    type t = T.t [@@deriving compare, sexp, sexp_grammar]

    let hash_fold_t = hash_fold_t
    let hash = hash

    include Bin_prot.Utils.Make_binable_without_uuid [@alert "-legacy"] (struct
        module Binable = Bin_prot.Md5

        type t = Bin_prot.Md5.t

        let to_binable = Fn.id
        let of_binable = Fn.id
      end)
  end

  let digest_string s = Md5_lib.string s
end

include Stable.V1
include Comparable.Make (Stable.V1)
include Hashable.Make (Stable.V1)

let digest_num_bytes = 16
let to_hex = T.to_hex
let from_hex = T.of_hex_exn
let of_hex_exn = T.of_hex_exn
let of_binary_exn = T.of_binary_exn
let to_binary = T.to_binary
let digest_string = Stable.digest_string
let digest_bytes = Md5_lib.bytes

external caml_sys_open
  :  string
  -> Caml.open_flag list
  -> perm:int
  -> int
  = "caml_sys_open"

external caml_sys_close : int -> unit = "caml_sys_close"
external digest_fd_blocking : int -> string = "core_md5_fd"

let digest_file_blocking path =
  of_binary_exn
    (Base.Exn.protectx
       (caml_sys_open path [ Open_rdonly; Open_binary ] ~perm:0o000)
       ~f:digest_fd_blocking
       ~finally:caml_sys_close)
;;

let file = digest_file_blocking

let digest_channel_blocking_without_releasing_runtime_lock channel ~len =
  of_binary_exn (Caml.Digest.channel channel len)
;;

let channel channel len =
  digest_channel_blocking_without_releasing_runtime_lock channel ~len
;;

let output_blocking t oc = Caml.Digest.output oc (to_binary t)
let output oc t = output_blocking t oc
let input_blocking ic = of_binary_exn (Caml.Digest.input ic)
let input = input_blocking
let digest_subbytes = Md5_lib.subbytes
let string = digest_string
let bytes = digest_bytes
let subbytes s pos len = digest_subbytes s ~pos ~len

let digest_bin_prot writer value =
  digest_string (Core_bin_prot.Writer.to_string writer value)
;;

external c_digest_subbigstring
  :  Bigstring.t
  -> pos:int
  -> len:int
  -> res:Bytes.t
  -> unit
  = "core_md5_digest_subbigstring"

let unsafe_digest_subbigstring buf ~pos ~len =
  (* It's more efficient to allocate the result on the OCaml side and declare the C
     function as noalloc than to let the C function allocate. *)
  let res = Bytes.create 16 in
  c_digest_subbigstring buf ~pos ~len ~res;
  Md5_lib.unsafe_of_binary
    (Bytes.unsafe_to_string ~no_mutation_while_string_reachable:res)
;;

let digest_subbigstring buf ~pos ~len =
  Ordered_collection_common.check_pos_len_exn
    ~pos
    ~len
    ~total_length:(Bigstring.length buf);
  unsafe_digest_subbigstring buf ~pos ~len
;;

let digest_bigstring buf =
  unsafe_digest_subbigstring buf ~pos:0 ~len:(Bigstring.length buf)
;;