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