vblt.org
forked from
gazagnaire.org/irmin
Persistent store with Git semantics: lazy reads, delayed writes, content-addressing
1let err_invalid_hex pos =
2 Error (`Msg (Fmt.str "invalid hex character at position %d" pos))
3
4type algorithm = Sha1 | Sha256
5
6type _ t =
7 | Sha1_hash : string -> [ `Sha1 ] t
8 | Sha256_hash : string -> [ `Sha256 ] t
9
10type sha1 = [ `Sha1 ] t
11type sha256 = [ `Sha256 ] t
12
13let sha1 data = Sha1_hash Digestif.SHA1.(to_raw_string (digest_string data))
14
15let sha256 data =
16 Sha256_hash Digestif.SHA256.(to_raw_string (digest_string data))
17
18let sha1_of_bytes raw =
19 if String.length raw <> 20 then
20 invalid_arg "Hash.sha1_of_bytes: expected 20 bytes";
21 Sha1_hash raw
22
23let sha256_of_bytes raw =
24 if String.length raw <> 32 then
25 invalid_arg "Hash.sha256_of_bytes: expected 32 bytes";
26 Sha256_hash raw
27
28let to_bytes : type a. a t -> string = function
29 | Sha1_hash s -> s
30 | Sha256_hash s -> s
31
32let to_hex h =
33 let bytes = to_bytes h in
34 let buf = Buffer.create (String.length bytes * 2) in
35 String.iter
36 (fun c -> Buffer.add_string buf (Fmt.str "%02x" (Char.code c)))
37 bytes;
38 Buffer.contents buf
39
40let hex_to_bytes hex =
41 let len = String.length hex in
42 if len mod 2 <> 0 then Error (`Msg "hex string has odd length")
43 else
44 let bytes = Bytes.create (len / 2) in
45 let rec loop i =
46 if i >= len then Ok (Bytes.to_string bytes)
47 else
48 let hi = hex.[i] and lo = hex.[i + 1] in
49 let decode c =
50 match c with
51 | '0' .. '9' -> Some (Char.code c - Char.code '0')
52 | 'a' .. 'f' -> Some (Char.code c - Char.code 'a' + 10)
53 | 'A' .. 'F' -> Some (Char.code c - Char.code 'A' + 10)
54 | _ -> None
55 in
56 match (decode hi, decode lo) with
57 | Some h, Some l ->
58 Bytes.set bytes (i / 2) (Char.chr ((h lsl 4) lor l));
59 loop (i + 2)
60 | _ -> err_invalid_hex i
61 in
62 loop 0
63
64let sha1_of_hex hex =
65 match hex_to_bytes hex with
66 | Error _ as e -> e
67 | Ok bytes ->
68 if String.length bytes <> 20 then
69 Error (`Msg "SHA-1 hex must be 40 characters")
70 else Ok (Sha1_hash bytes)
71
72let sha256_of_hex hex =
73 match hex_to_bytes hex with
74 | Error _ as e -> e
75 | Ok bytes ->
76 if String.length bytes <> 32 then
77 Error (`Msg "SHA-256 hex must be 64 characters")
78 else Ok (Sha256_hash bytes)
79
80type existential = Ex : _ t -> existential
81
82let of_hex algo hex : (existential, [> `Msg of string ]) result =
83 match algo with
84 | Sha1 -> Result.map (fun h -> Ex h) (sha1_of_hex hex)
85 | Sha256 -> Result.map (fun h -> Ex h) (sha256_of_hex hex)
86
87let equal : type a. a t -> a t -> bool =
88 fun h1 h2 -> String.equal (to_bytes h1) (to_bytes h2)
89
90let compare : type a. a t -> a t -> int =
91 fun h1 h2 -> String.compare (to_bytes h1) (to_bytes h2)
92
93let length : type a. a t -> int = function
94 | Sha1_hash _ -> 20
95 | Sha256_hash _ -> 32
96
97let algorithm_of : type a. a t -> algorithm = function
98 | Sha1_hash _ -> Sha1
99 | Sha256_hash _ -> Sha256
100
101let algorithm_length = function Sha1 -> 20 | Sha256 -> 32
102
103let mst_depth (Sha256_hash bytes) =
104 let rec count_zeros i acc =
105 if i >= 32 then acc
106 else
107 let byte = Char.code bytes.[i] in
108 let hi = (byte lsr 6) land 0x3 in
109 let mid_hi = (byte lsr 4) land 0x3 in
110 let mid_lo = (byte lsr 2) land 0x3 in
111 let lo = byte land 0x3 in
112 if hi <> 0 then acc
113 else if mid_hi <> 0 then acc + 1
114 else if mid_lo <> 0 then acc + 2
115 else if lo <> 0 then acc + 3
116 else count_zeros (i + 1) (acc + 4)
117 in
118 count_zeros 0 0
119
120type any = Any : _ t -> any
121
122let any_algorithm (Any h) = algorithm_of h
123let any_to_bytes (Any h) = to_bytes h
124let any_to_hex (Any h) = to_hex h
125let equal_any (Any h1) (Any h2) = any_to_bytes (Any h1) = any_to_bytes (Any h2)
126let pp fmt h = Fmt.pf fmt "%s" (to_hex h)
127
128let pp_short fmt h =
129 let hex = to_hex h in
130 Fmt.pf fmt "%s" (String.sub hex 0 (min 7 (String.length hex)))